perm filename IL[IL,LSP]3 blob
sn#201270 filedate 1976-02-13 generic text, type C, neo UTF8
COMMENT ⊗ VALID 00066 PAGES
C REC PAGE DESCRIPTION
C00001 00001
C00006 00002 SUBTTL NOTES TO SYSTEM PROGRAMMERS
C00009 00003 SWITCHES, SYSTEM NAMES, AC DEFINITIONS AND EXTERNALS
C00020 00004 SUBTTL TOP LEVEL AND INITIALIZATION
C00025 00005
C00033 00006 SUBTTL APR INTERRUPT ROUTINES
C00035 00007 SUBTTL UUO HANDLER AND SUBR CALL ROUTINES
C00046 00008 SUBTTL ERROR HANDLER AND BACKTRACE
C00054 00009 error messages
C00059 00010 SUBTTL TYI, ITYI, etc., Tyi and Tyo
C00079 00011 TYO, TTYO, etc., Tyo
C00087 00012 SUBTTL Input and Output Initialization and Control -- SIXMAK, NEXTIO, SIXRT
C00089 00013 IOSUB AND FRIENDS (CHNSUB,DEVCHK)
C00093 00014 Channel table definitions
C00096 00015 search for channel name in chtab
C00099 00016 INPUT, ISFILE, RENAME
C00109 00017 OUTPUT
C00112 00018 INOUT
C00115 00019 USETI, USETO, CHSETI, CHSETO
C00119 00020 IOSEL
C00121 00021 INCNT, INC
C00125 00022 OUTCNT, OUTC
C00128 00023 SUBTTL QMANGR INTERFACE
C00156 00024 SUBTTL PRINT
C00158 00025
C00163 00026 SUBTTL SUPER FAST TABLE DRIVEN READ 14-MAY-69
C00180 00027 number scanner
C00185 00028 identifier interner
C00190 00029 INTERN: MOVEM A,AR2A
C00191 00030 READ, CONTINUED.
C00194 00031 SUBTTL LISP INTERPRETER SUBROUTINES
C00200 00032 MORE INTERPRETER ROUTINES
C00204 00033 PUTPROP:
C00212 00034 LIST and ILIST (and EELS)
C00214 00035 NEW AND SUPER POWERFUL MAP FUNCTIONS
C00217 00036 PROG, COND, SETQ, LEXORD
C00223 00037 ARITHMETIC SUBROUTINES
C00230 00038 SUBTTL EXPLODE, READLIST AND FRIENDS
C00234 00039 SUBTTL EVAL,APPLY -- THE INTERPRETER
C00239 00040 HANDLER OF ALISTS AND SPDL CONTEXT POINTERS
C00242 00041
C00245 00042 APPLY LAMBDA
C00249 00043 BIND AND UNBIND
C00255 00044 SUBTTL ARRAY SUBROUTINES
C00262 00045 SUBTTL EXAMINE, DEPOSIT , ETC
C00263 00046 GC -- GARBAGE COLLECTOR - Marking phase.
C00271 00047 GC Sweep phase.
C00275 00048 SUBTTL SYMBOL TABLE ACCESSING ROUTINES AND DDT INTERFACE
C00278 00049 SUBTTL SPRINT -- THE PRETTY PRINTER
C00288 00050 SUBTTL SAIL-LISP INTERFACE
C00290 00051 ** LISP to SAIL
C00292 00052 ** SAIL to LISP
C00295 00053 ** save an LISP system and diddle starting address
C00296 00054 ** explicit call for RESCHEDULE by LISP
C00297 00055 SUBTTL LOADER INTERFACE
C00306 00056 CORE MANAGEMENT ROUTINES.(MORCOR,MOVSYM,EXCISE,REMSYM)
C00310 00057 SUBTTL HIGH SEGMENT FUNCTIONS
C00314 00058 SUBTTL REALLOC CODE
C00330 00059 NEW FUNCTIONS TO MAKE USE OF MODIFIED SPECIAL PDL FOR ERRORS
C00337 00060 SUBTTL LOW SEGMENT INCLUDING REMOTE CODE
C00338 00061 SUBTTL LISP ATOMS AND OBLIST
C00343 00062 THE GREAT OBLIST EXPLOSION...
C00353 00063
C00358 00064 XLIST Now we clean up the debris from the explosion...
C00360 00065 SUBTTL LISP STORAGE ALLOCATOR (ONCE ONLY)
C00362 00066 INTERNAL and EXTERNAL declarations
C00365 ENDMK
C⊗;
; SUBTTL NOTES TO SYSTEM PROGRAMMERS
;$$$ ASSEMBLY SWITCHES OF INTEREST $$$
;
; SWITCH EXPLANATION, COMMENTS ETC.
;
; SAIL MAKES LISP RUNNABLE INSIDE A SAIL CORE-IMAGE
; ALTMOD FOR ALTMODE CHARACTER. OLD WAS 175
; NOW IT'S 33 FOR 506
; QALLOW ENABLES ACCESS TO QMANGR, ONLY IF YOUR
; SYSTEM SUPPORTS QUEUE. SEVERAL SWITCHES
; ASSOCIATED WITH THE CODE
; OLDNIL OLD STANFORD NIL. CODE TO MAKE CAR AND CDR
; OF NIL INCOMPLETE AS OF 8/30/73
; NONUSE OLD STANFORD VERSIONS OF MEMQ, AND ETC.
; THAT RETURNED T OR NIL.
; SYSPRG PROJECT NUMBER IF NOT ON SYS:.
; SYSPN PROGRAMMER NUMBER IF NOT ON SYS:
; SYSDEV DEVICE LOCATION OF SYSTEM.
; NOTE THAT THE ABOVE THREE ARE WHERE LISP
; EXPECTS TO FIND THE LOADER,THE
; SYMBOL TABLE AND THE NORMAL HI-SEGMENT.
; **USE FOLLOWING AT OWN RISK**
; HASH NUMBER OF HASH BUCKETS WHEN STARTING
; ALVINE STANFORD EDITOR (WHO WOULD WANT IT?)
; 1 FOR ALVINE, 0 FOR NO ALVINE
; STPGAP ANOTHER STANFORD EDITOR
;$$$ Special functions $$$
; The following 3 functions all take a file spec. in the same
; form as INPUT.
; (SETSYS <fs>) THE FUNCTION (SETSYS ...) CHANGES THE
; EXPECTED LOCATION OF THE HI-SEG; the function
; (SETLOD <fs>) (SETLOD) changes the loc. of the loader.
; (SETSYM <fs>) (SETSYM) changes the loc. of the symbol table.
;$$$ COMMENTS $$$
; THERE ARE BASICALLY TWO SETS OF COMMENTS IN THE CODE.
; THOSE IN LOWER CASE ARE STANFORD COMMENTS.
; THOSE OF A SEMI-COLON FOLLOWED BY TWO $'S,
; TWO #'S, OR TWO %'S ARE UCI ADDITIONS,
; CHANGES, OR ADDITIONAL COMMENTS.
; ($'S ARE USUALLY DARYLE LEWIS,
; #'S ARE GENERALLY JEFF JACOBS,
; AND %'S ARE GENERALLY BILL EARL.)
; ** IS AJT.
;SWITCHES, SYSTEM NAMES, AC DEFINITIONS AND EXTERNALS
IFNDEF DEBUGX {DEBUGX ←← 0} ;NON-ZERO FOR DEBUGGING VERSIONS.
IFNDEF ONESEG {ONESEG ←← 0} ;Non-zero for one-segment LISP system.
IFNDEF SAIL {SAIL ←← 0} ;Makes IL run in a sail core-image ( oh, joy!)
IFNDEF FOL {FOL ←← 0} ;Makes IL into a FOL core image
IFE DEBUGX ∨ ONESEG ∨ SAIL {TITLE IL INTERPRETER;}
IFN DEBUGX {IFE SAIL {TITLE ILX INTERPRETER;}}
IFN SAIL {TITLE ILSAI INTERPRETER;}
IFN ONESEG ∧ ¬DEBUGX ∧ ¬SAIL {TITLE IL1 INTERPRETER;}
SYSNAM ←← 'IL ' ;NAME OF PROGRAM AND SEGMENT.
IFN DEBUGX {SYSNAM ←← 'ILX '}
IFN SAIL {SYSNAM ←← 'ILSAI '}
IFN FOL {SYSNAM ←← 'FOL '}
SYSPRJ ←← ' 1' ;PPN of LISP system. This is used for getting 1) the segment and
SYSPRG ←← ' 3' ;and 2), loader and symbols respectively.
IFN FOL {SYSPRJ ←← 'SYS'
SYSPRG ←← 'RWW' }
SYSPPN ←← <SYSPRJ,,SYSPRG>
LODNAM ←← 'LOD ' ;filename of LISP loader core image. Changeable by SETLOD.
SYMNAM ←← 'SYM ' ;filename of LISP symbol table. Changeable by SETSYM.
IFNDEF SYSPRJ,<SYSPRJ←←0
SYSPPN←←0>
IFE SYSPRJ,<DEFINE SYSDEV <SIXBIT /SYS/>>
IFN SYSPRJ,<DEFINE SYSDEV <SIXBIT /DSK/>>
OLDNIL ←← 1 ;## NEW NIL NOT COMPLETE
ML2 ←← 1 ;make MLISP2 work
define ifsail(var,val1,val2) {ife sail {var←←val1}
ifn sail {var←←val2} }
define poll {
ifn sail< ; this simulates a SAIL polling point
skipe intrpt ; is there a reschedule request pending?
jrst lspsai ; yes, so go to SAIL
>
}
STANSW ←← 1
QALLOW ←← 0
QSWEXT ←← 0
IFNDEF NONUSE <NONUSE←←0>
IFNDEF QALLOW <QALLOW←←1>
;ALVINE←←1 ;1 FOR ALVINE, 0 FOR NO ALVINE
IFNDEF ALVINE,<ALVINE←←0>
;HASH←←1 ;1 FOR SETTING # OF HASH BUCKETS AT SYS. INIT. TIME
IFNDEF HASH,<HASH←←0>
STPGAP←←1 ;1 FOR STOPGAP, 0 TO DELETE IT
IFNDEF STPGAP,<STPGAP←←0>
INUMIN←377777
INUM0←<INUMIN+777777>/2
↓BCKETS←←177 ;Number of hash buckets in object list.
;accumulator definitions
;`sacred' means sacred to the interpreter
;`marked' means marked from by the garbage collector
;`protected' means protected during garbage collection
NIL←0 ;sacred, marked, protected ;atom head of NIL
A←1 ;marked, destroyed! ;results of functions and first arg of subrs
B←A+1 ;marked, protected ;second arg of subrs
C←B+1 ;marked, protected ;third arg of subrs
AR1←4 ;marked, protected ;fourth arg of subrs
AR2A←5 ;marked, protected ;fifth arg of subrs
T←6 ;marked, protected ;minus number of args in LSUBR call
TT←7 ;marked, protected
REL←10 ;marked, protected
LSTMAC←←REL ;This is the last marked ac.
S←11 ;$$NOW USED FOR ATOM RELOCATION AND GARBAGE COLLECTOR
D←12
R←13 ;protected
P←14 ;sacred, protected ;regular push down stack pointer
F←15 ;sacred ;free storage list pointer
FF←16 ;sacred ;full word list pointer
SP←17 ;sacred, protected ;special pushdown stack pointer
NACS ←← 5 ;number of argument acs
X ←← 0 ;X indicates impure (modified) code locations
TEN ←← =10
;UUO definitions
;UUOs used to call functions from compiled code
;the number of arguments is given by the ac field
;the address is a pointer either to the function
;name or the code of the function
OPDEF FCALL [34B8] ;ordinary function call-may be changed to PUSHJ
OPDEF JCALL [35B8] ;terminal function call-may be changed to JRST
OPDEF CALLF [36B8] ;like call but may not be changed to PUSHJ
OPDEF JCALLF [37B8] ;like jcall but may not be changed to JRST
OPDEF UUOTRT[33B8] ;Used to return from UUOTRACE'd function calls.
UUONPB ←← 1000 ;On for the UUO's which DO NOT PUSH a return addr.
UUONCB ←← 2000 ;On for the UUO's which MAY NOT BE CLOBBERD to a PUSHJ or JRST.
;error UUOs
OPDEF ERR1 [1B8] ;ordinary lisp error ;gives backtrace
OPDEF ERR2 [2B8] ;space overflow error ;no backtrace
OPDEF ERR3 [3B8] ;ill. mem. ref.
OPDEF STRTIP [4B8] ;print error message and continue
UUOMIN←←1 ;Bounds of error uuo's.
UUOMAX←←4
;system UUOs
OPDEF TTYUUO [51B8]
OPDEF INCHRW [TTYUUO 0,]
OPDEF OUTCHR [TTYUUO 1,]
OPDEF OUTSTR [TTYUUO 3,]
OPDEF INCHWL [TTYUUO 4,]
OPDEF INCHSL [TTYUUO 5,]
OPDEF CLRBFI [TTYUUO 11,]
OPDEF SKPINC [TTYUUO 13,]
OPDEF SKPINL [TTCALL 14,] ;## BETTER FOR TALK THAN SKPINC
OPDEF CLEARM [SETZM]
OPDEF CLEARB [SETZB]
OPDEF APRENB [CALLI 16]
DEFINE TALK {SKPINC↔JFCL} ;## TURN OFF CONTROL O
;I/O bits and constants
TTYLL ←← 105 ;teletype linelength
LPTLL ←← 160 ;line printer linelength
MLIOB ←← 203 ;max length of I/O buffer
NIOB ←← 2 ;no of I/O buffers per device
IFSAIL(NIOCH,17,10) ;number of I/O channels
IFSAIL(FSTCH,1,11) ;first I/O channel
IFSAIL(TTCH,0,10) ;teletype I/O channel
INB ←← 2
OUTB ←← 1
AVLB ←← 40
DIRB ←← 4
;special ASCII characters
ALTMOD ←← 175
SPACE ←← 40 ;space
IGCRLF ←← "→" ;Ignore from any occurence of this chr. THROUGH next crlf.
RUBOUT ←← 177
LF ←← 12
CR ←← 15
TAB ←← 11
BELL ←← 7
DBLQT ←← 42 ;double quote "
IFNDEF ALTMOD,<ALTMOD←←33>
IFN FOL {IGCRLF ←← "%"}
;byte pointer field definitions
ACFLD ←← 14 ;ac field
XFLD ←← 21 ;index field
OPFLD ←← 10 ;opcode field
ADRFLD ←← 43 ;address field
;external and internal symbols
EXTERNAL JOB41 ;instruction to be executed on UUO
EXTERNAL JOBAPR ;address of APR interupt routines
EXTERNAL JOBCNI ;interupt condition flags
EXTERNAL JOBFF ;first location beyond program
EXTERNAL JOBREL ;address of last legal instruction in core image
EXTERNAL JOBREN ;reentry address
EXTERNAL JOBSA ;starting address
EXTERNAL JOBSYM ;address of symbol table
EXTERNAL JOBTPC ;program counter at time of interupt
EXTERNAL JOBUUO ;uuo is put here with effective address computed
EXTERNAL JOBOPC ;$$FOR NEW REENTER FEATURES
EXTERNAL JOBHRL ;HIGH SEGMENT BOUNDARY
;apr flags
PDOV ←← 200000 ;push down list overflow
MPV ←← 20000 ;memory protection violation
NXM ←← 10000 ;non-existant memory referenced
APRFLG ←← PDOV+MPV+NXM ;any of the above
;RE-ENTER CONTROL CHARACTERS
CNTLH←←200+"H" ;Stanford <ctrl> bit.
CNTLHH←←"H"-100 ;λ or ordinary CONTROL-H
CNTLE←←200+"E"
CNTLB←←200+"B"
CNTLZ←←200+"Z"
CNTLG←←200+"G"
CNTLGG←←"G"-100 ;π or ordinary CONTROL-G
CNTLR←←200+"R" ;CH TO RESTORE SYSTEM OBLIST 3/28/73
;system uuos
RESET ←← 0
STIME ←← 27
DEVCHR ←← 4
EXIT ←← 12
CORE ←← 11
CORE2 ←← 400015 ;Stanford uppper seg. core uuo.
UNPURE ←← 400102 ;Stanford-- make private, writable copy of my segment.
SETNM2 ←← 400036 ;Stanford-- rename segment.
SETUWP ←← 36
GETSEG ←← 40
IFE ONESEG {
DEFINE REMOTE(X)<USE LOW
X
USE HIGH>
TWOSEG
USE LOW ;Init. lower segment loc. counter.
SHRST←←400000
USE HIGH ;Init. upper segment loc. counter.
RELOC SHRST
} ;end if IFE ONESEG
IFN ONESEG {
DEFINE REMOTE(X) {X}
USE LOW
}
SUBTTL TOP LEVEL AND INITIALIZATION
IFE ONESEG {
REMOTE {
LISPGO: SKIPE GCFLG ;$$CHECK FO GARBAGE COLLECTION
PUSHJ P,GCING ;$$QUEUE THE REQUEST
MOVE A,SEGNME ; Get high segment name *** MJC
CALLI A,400016 ; Attach to high seg if poss. *** MJC
CAIE A,4 ; If err←4 (seg alrdy there) ok too *** MJC
SKIPGE JOBHRL ;Got one. is it write protected ?
JRST SGPROT ; Success! *** MJC
;Can't get a (write-protected) segment. Make one.
CALLI 400017 ; Detach stray segments. *** MJC
OPEN 0,SEGOPEN ; Init ch 0 to dump mode. *** MJC
JRST NOSEG ; Couldn't do it? *** MJC
MOVE A,SEGPPN ; Get ppn of high seg file. *** MJC
MOVEM A,SEGPPX ; Store for LOOKUP. *** MJC
LOOKUP 0,SEGNME ; Find file containing high seg *** MJC
JRST NOSEG ; No high seg file -- collapse *** MJC
HLRE A,SEGPPX ; Ppn was replaced by -length *** MJC
MOVNS A ; Fix up for CORE2. *** MJC
SUBI A,1 ;Highest addr. needed is size-1.
CALLI A,CORE2 ; Grab core for high segment. *** MJC
JRST NOSEG ; Can't get it? *** MJC
MOVE A,SEGNME ; Name the high segment. *** MJC
CALLI A,SETNM2 ; SEGNM2 uuo. *** MJC
JRST NOSEG ; Pretty weird. *** MJC
MOVEI A,SHRST-1 ; For dump mode input. *** MJC
HRRM A,SEGPPX ; *** MJC
IN 0,SEGPPX ; Fill high seg with goodies. *** MJC
SGPROT: TLOA -1
JRST NOSEG
IFE SAIL,< SETUWP ; Write-protect segment. *** MJC
JRST NOSEG > ; rather than turn him loose. *** MJC
RELEASE 0, ; Destroy fingerprints. *** MJC
;printx The following is a temporary kludge
MOVEI A,0 ;MOVE TO HIGH CORE
LTHUUO A,
JFCL
JRST STRT ;GO TO ALLOCATE STORAGE
NOSEG: OUTSTR NOSEGM
HALT ; *** MJC
NOSEGM: ASCIZ/CAN'T GET HIGH SEGMENT!/ ; *** MJC
SEGNME: SYSNAM ; High segment job & file name *** MJC
SEGEXT: SIXBIT/SEG/ ; High seg file extension. *** MJC
0
SEGPPX: 0 ; PRG,PPN of high seg file. *** MJC
; Also file length after LOOKUP *** MJC
0 ; Used as dump wd cmd list. *** MJC
SEGPPN: XWD SYSPRJ,SYSPRG ; High seg file area *** MJC
SEGOPEN:17 ; Data mode. *** MJC
SEGDEV: SYSDEV ; Dev name (defd before OPEN) *** MJC
0 ; Buffer indicators (none) *** MJC
PATCHL: BLOCK 40
};;end REMOTE
} ;;END IFE ONESEG
IFN ONESEG {LISPGO: JRST STRT}
.DDT: SETOM ERINT ;$$SET CONTROL H WITHOUT GOING THRU REE
JRST @JOBOPC ;$$AND CONTINUE
DEBUGO: SKIPE GCFLG# ;CHECK GARBAGE COLLECT.
PUSHJ P,GCING ;QUEUE INTERRUPT
DEBUGL: INCHRW 0 ;READ THE CONTROL CHARACTER
TRZ 40 ;Make lower case like upper.
CAIN 0,CNTLR
; RESTORES SYSTEM OBLIST
JRST [HRRI 0,OBTBL(S)
HRRM 0,VOBLIST(S)
JRST DEBUGL]
; AND TRIES FOR ANOTHER CONTROL CHARACTER
CAIE 0,CNTLHH
CAIN 0,CNTLH
JRST [MOVE 0,STNIL
JRST .DDT]
CAIN 0,CNTLE
JRST [MOVE 0,STNIL
MOVEI 1,NIL
JRST ERR]
CAIN 0,CNTLB
JRST [MOVE 0,STNIL
SETOM ERINT
PUSHJ P,SPDLPT
PUSHJ P,SPREDO
JRST LSPRET]
CAIN 0,CNTLZ
JRST [MOVE 0,STNIL
JRST LSPRET]
CAIE 0,CNTLGG
CAIN 0,CNTLG
JRST [MOVE 0,STNIL
JRST RERX]
JRST DEBUGL ;NOT A CONTROL CHARACTER
;MUST BE SOMETHING IN THE BUFFER SO TRY AGAIN
.SYSNAM:STRTIP [SYSNAM↔'! ']
JRST FALSE
START:
IFE SAIL{ CALLI RESET} ;random initializations for lisp interupts
MOVE [JSR UUOH]
MOVEM JOB41
ife sail {
MOVEI APRINT
MOVEM JOBAPR
MOVEI APRFLG
APRENB ; this is really APRENB!!
}
SETZM GCFLG
HRRZI 17,1
IFN ALVINE,<SETZB 0,PSAV1>
IFE ALVINE,<SETZ 0,>
BLT 17,17 ;clear acs
LSPRT1: MOVE S,ATMOV ;$$SET UP RELOCATION FOR INTERNAL ATOMS (FOOLIST)
MOVE P,C2# ;initial reg pdl ptr
MOVE SP,SC2# ;initial spec pdl ptr
SETZM BIOCHN(S) ;$$CLEAR VARS FOR BREAK PACKAGE
SETZM BPMPT(S) ;$$(#%IOCHNAS%#, #%PROMPTS%#, AND #%INDENT)
MOVEI A,INUM0
MOVEM A,BINDNT(S)
SETZM ERINT# ;$$TURN OFF INTERRUPT FLAG
SETOM ERRSW ;print error messages
SETZM ERRTN# ;return to top level on errors
SETOM PRVCNT# ;initialize counter for errio
;The following kluge provides a sort if `external initfun' feature.
SKIPE %SCNSF(S) ;Is the SCAN package (or whatever) around ?
PUSHJ P,@%SCNSF(S) ;Yes. Call SCANRESET, or whatever the user wants.
MOVE A,LSPRMP# ;$$INITIALIZE TO TOP LEVEL PROMPT; CAN BE CHANGED BY INITPROMPT
SPATCH: PUSHJ P,PROMPT ;$$
SETZM SMAC ;$$CLEAR SPLICE LIST (JUST IN CASE)
PUSHJ P,TTYRET ;(outc nil t)(inc nil t)return output for gc message
IFN OLDNIL <HRROI 0,CNIL2(S)> ;INITIALIZE NIL
IFE OLDNIL <SETZ 0, >
MOVEM 0,STNIL# ;$$SAVE FOR REG CHECK AT START TIME
MOVEI A,CNIL2(S) ;## GET PROP LIST OF NIL
MOVEM A,NILPRP# ;## AND SAVE IT FOR GET ETC.
IFN HASH,<
SKIPE HASHFG#
JRST REHASH ;rehash if necessary>
AOSE REALFLG# ;Force garbage collect if we have just reallocated.
SKIPN F
PUSHJ P,AGC ;garbage collect only if necessary
SKIPN BSFLG# ;initial bootstrap for macros
JRST BOOTS
SKIPE A,INITF
CALLF (A) ;evaluate initialization function
PUSHJ P,TTYRET ;return all i/o to tty
PUSHJ P,TYIGRS ;Clear the type-ahead saving stuff.
PUSHJ P,TSAVRS ;Clear the input saving stuff.
PUSHJ P,TERPRI
SKIPE GOBF# ;garbaged oblist flag
STRTIP [SIXBIT /GARBAGED OBLIST←!/]
SETZM GOBF
SKIPE BPSFLG#
JRST BINER2 ;binary program space exceeded by loader
LISP1: MOVE S,ATMOV# ;$$MAKE SURE REL STAYS
;$$SET UP - BELT AND SUSPENDERS TECHNIQUE
PUSHJ P,READ ;this is the top level of lisp
PUSHJ P,EVAL
PUSHJ P,PRINT
PUSHJ P,TERPRI
JRST LISP1
.EXIT: PUSHJ P,EXCISE ;Leave a clean core image.
PUSHJ P,GC
MOVEM F,XFSAVE# ;So we wont't have to garbage collect when we restart.
MOVEM FF,XFFSAVE#
MOVEI T,XREST
MOVEM T,%SCNSF(S) ;START will now call us.
EXIT
XREST: MOVE F,XFSAVE ;Here we are, restarting without a GC !
MOVE FF,XFFSAVE
SETZM %SCNSF(S)
POPJ P,
INITFL: EXCH A,INITF1# ;## NEW INIT FILE LIST
POPJ P, ;## RETURN THE OLD ONE
INITFN: EXCH A,INITF#
POPJ P,
;return from lisp error
LSPRET: PUSHJ P,TERPRI
MOVE B,SC2 ;RETURN FROM BELL
PUSHJ P,UBD ;unbind specpdl
JRST LSPRT1
.RSET: EXCH A,RSTSW#
POPJ P,
COMMENT %
;## OLD BOOTSTRAP CODE FOR INIT FILE, REPLACED BELOW
;BOOTSTRAPPER FOR USER'S INIT FILE
BOOTS: SETOM BSFLG
MOVE A,[POINT 7,[ASCII /(ERRSET[INC(INPUT DSK:(INIT.LSP]NIL)[(EVAL(READ]/]]
MOVEM A,BOOPT#
MOVEI A,BSTYI
PUSHJ P,READP1
PUSHJ P,EVAL
JUMPE A,BOOTOT
MOVEI A,BSTYI
PUSHJ P,READP1
PUSH P,A
MOVE A,(P)
PUSHJ P,ERRSET
CAIE A,$EOF$(S)
JRST .-3
BOOTOT:
PUSHJ P,EXCISE
JRST ERR
BSTYI: ILDB A,BOOPT
POPJ P,
%
;## NEW IMPROVED BOOTSTRAPPER FOR USER'S INITFILE(S)
;## ALLOWS MORE THAN ONE FILE. FIRST FILE IS READ IN
;## OR IF NOT FOUND BEHAVES AS BEFORE (I.E. NO ERROR MESSAGE)
;## REMAINING FILES WILL CAUSE AN ERROR MESSAGE IF NOT FOUND.
;## THUS IF THE USER IS USING THIS TO REALLY SET UP HIS OWN
;## SYSTEM, HE WILL KNOW ABOUT A FAILURE, BUT THE FIRST
;## FILES EXISTENCE IS STILL OPTIONAL
BOOTS: SETOM BSFLG# ;## INDICATE BOOTSTRAP DONE
SKIPN T,INITF1# ;## GET INIT FILE LIST IF IT EXISTS
JRST BOOTOT ;## NOPE, EXCISE AND RETURN
MOVEI A,TRUTH(S) ;## USE CHANNEL T
PUSHJ P,INPUT2 ;## SET UP
PUSHJ P,ININIT ;## LOOK UP
JUMPN A,BOOTOK ;## IT'S THERE, GO TO IT
JUMPE T,BOOTOT ;## NOT THERE AND NO OTHERS REQUESTED
PUSHJ P,SETINA ;## SET UP FOR THE REST
PUSHJ P,ININIT ;## LOOK UP (SECOND FILE IN LIST)
JUMPE A,AIN.7 ;## NOT THERE, ERROR MESSAGE
BOOTOK: MOVEI A,TRUTH(S) ;##(INC T NIL)
SETZ B,
PUSHJ P,INC ;## SELECT
MOVEI A,READAT(S) ;## SET UP [(EVAL (READ))]
PUSHJ P,NCONS ;## (READ)
PUSHJ P,NCONS ;## ((READ))
MOVEI B,EVALAT(S)
PUSHJ P,XCONS ;##(EVAL(READ))
PUSHJ P,NCONS ;## [(EVAL(READ))]
PUSH P,A
MOVE A,(P)
PUSHJ P,ERRSET ;## AN EVAL-READ LOOP. PROTECTED AGAINST
CAIE A,$EOF$(S) ;## ALL ERRS EXCEPT $EOF$ AND ERRORX
JRST .-3 ;## LOOP
BOOTOT:
IFE SAIL,< PUSHJ P,EXCISE> ; ** This would make SAIL Unhappy
JRST ERR
PAGE
SUBTTL APR INTERRUPT ROUTINES
;arithmetic processor interrupts
;mem. protect. violation, nonex. mem. or pdl overflow
APRINT: MOVE R,JOBCNI ;get interupt bits
TRNE R,MPV+NXM ;what kind
ERR3 @JOBTPC ;an ill mem ref-will become JRST ILLMEM
JUMPN NIL,MES21 ;a pdl overflow
STRTIP [SIXBIT /←PDL OVERFLOW FROM GC - CAN'T CONTINUE!/]
JRST START
MES21: SKIPL P
OUTSTR [ASCIZ /⊗REG /]
SKIPL SP
OUTSTR [ASCIZ /⊗SPEC /]
SPDLOV: ERR2 [SIXBIT /PUSHDOWN CAPACITY EXCEEDED !/]
; TRNE R,PDOV
; SKIPE JOBUUO
; HALT ;lisp should not be here
BINER2: SETZM BPSFLG
ERR2 [SIXBIT /BINARY PROGRAM SPACE EXCEEDED !/]
ILLMEM: LDB R,[POINT 4,@JOBTPC,XFLD] ;get index field of bad word
CAIE R,F ;does it contain f
ERR3 @JOBTPC ;no! error
PUSHJ P,AGC ;yes! garbage collect
JRST @JOBTPC ;and continue
SUBTTL UUO HANDLER AND SUBR CALL ROUTINES
REMOTE<UUOH: X ;jsr location
JRST UUOH2>
UUOH2: MOVEM T,TSV#
MOVEM TT,TTSV#
LDB T,[POINT 9,JOBUUO,OPFLD] ;get opcode
CAIGE T,33 ;Is it a LISP error ?
JRST ERROR ;Yes.
CAIN T,33 ;...or the return from a UUOTRACE'd funct ?
JRST UUOUTR ;Yes.
HRRZ T,UUOH ;It's a function call.
MOVEM T,UUOCAL
HLRE R,@JOBUUO ;Does it point to an atom ?
AOJN R,UUOS ;If not, assume it points to a real SUBR.
SKIPE UUOTRF ;Do we want complete tracing ? (UUOTRACE T)
JRST UUOTRC ;Yes. Put an EVAL BLIP on stack.
UUOTRX: LDB T,[POINT 4,JOBUUO,ACFLD]
MOVEI R,0 ;Load R with 0,1,or 2 if calling normal,L,or F, respectively.
CAILE T,15
MOVEI R,-15(T)
HRRZ T,@JOBUUO
UUOH1: HLRZ TT,(T)
HRRZ T,(T)
CAIN TT,SUBR(S)
JRST @UUST(R)
CAIN TT,FSUBR(S)
JRST @UUFST(R)
CAIN TT,LSUBR(S)
JRST @UULT(R)
CAIN TT,EXPR(S)
JRST @UUET(R)
CAIN TT,FEXPR(S)
JRST @UUFET(R)
HRRZ T,(T)
JUMPN T,UUOH1
PUSH P,A
PUSH P,B
HRRZ A,JOBUUO
MOVEI B,VALUE(S)
PUSHJ P,GET
JUMPN A,[ HRRZ TT,(A)
POP P,B
POP P,A
JRST UUOEX1]
HRRZ A,JOBUUO
PUSHJ P,EPRINT
ERR1 [SIXBIT /UNDEFINED FUNCTION (CALLED BY UUO)!/]
UUOTRC: PUSH P,A ;We will make this look like an interpreted call for
PUSH P,B ; the benefit of the break package...
LDB T,[POINT 4,JOBUUO,ACFLD]
CAIN T,17 ;If an F type, A already contains list of args.
JRST UUOTR3
CAIE T,16 ;What type of call is this ?
JRST UUOTR5 ;A normal (SUBR) type.
MOVE TT,TSV ;An LSUBR type. Pick up -(no. of args).
ADD TT,[PUSH P,-1(P)]
SKIPA T,TSV ;Copy its arguments to top of stack.
XCT TT
AOJLE T,.-1
SKIPA T,TSV
UUOTR5: JSP TT,ARGPDL ;Regular call. Get args. onto pdl. and go to UUOTR4.
UUOTR4: JSP TT,QTLFY ;Regular or L. Make list in A of the quoted args .
UUOTR3: MOVE B,JOBUUO ;Get name of funtion (or pososibly it's a form).
PUSHJ P,XCONS ;CONS onto list of args. We now have a form (which
PUSH SP,A ; we stack as part of our fake EVAL blip) which
MOVEI T,-2(P) ; will EVAL to the same result as the present
LDB B,[POINT 4,JOBUUO,ACFLD] ; (compiled) function call.
CAIN B,16 ;Now we make a ptr. to the return addr. for this call.
ADD T,TSV ;(An LSUBR call, so return addr. is under args.)
MOVSI TT,UUONPB
TDNN TT,JOBUUO ;Are we going to push a new return addr. ?
AOSA T ;Yes. Here is where it will be.
SKIPA A,(T) ;No. Pick up the previous return addr.
MOVE A,UUOH ;Yes. Get the new return addr.
HRLI A,(<UUOTRT>) ;Make a return uuo.
DPB B,[POINT 4,A,ACFLD]
PUSHJ P,FWCONS ;Put it in FWS.
HRRM A,UUOH ;Put its location in UUOH where it will get PUSH'ed as the
TDNE TT,JOBUUO ; return addr.
HRRM A,(T) ;Not PUSH'ing a new addr., so fix up the old one.
UUOTR2: HRLI T,UNBOUND(S)
PUSH SP,(SP) ;Make an EVAL BLIP, just as if this call had been
MOVEM T,-1(SP) ; interpreted.
POP P,B
POP P,A
JRST UUOTRX
UUOUTR: ;We are returning from some function we UUOTRCed.
SOS TT,UUOH ;Get loc. of UUOTRT uuo.
MOVEM FF,(TT) ;Return it to the FWS fre list.
HRRZ FF,TT
HLLZ TT,(SP)
HRR TT,-1(SP)
CAIE TT,1(P) ;Is top thing on SP the correct EVAL blip ?
JRST UUOUTX ;No. Somebody did something funny with SP. Just return.
MOVE T,(SP) ;Now return the fake form to free storage so we won't be
LDB TT,[POINT 4,JOBUUO,ACFLD] ;the cause of infinite garbage collecting.
CAIN TT,17 ;Are we returning from an F-type function ?
JRST UUOUT2 ;Yes. The rest of the form (the arg. list) is real.
HRRZS TT,(T)
JUMPE TT,UUOUT2 ;(Go through the form setting the CAR's to NIL.)
UUOUT1: MOVE T,TT ;Get next top-level word of form...
HRRZ TT,(T) ;Save its CDR.
HLRZS T,(T) ;Flush the (QUOTE <arg>).
HRRZS T,(T)
MOVEM TT,(T) ;Append what's left to be freed.
JUMPN TT,UUOUT1
UUOUT2: MOVEM F,(T) ;Done. Append the freelist to the flattened
POP SP,F ; remnant of the form.
SUB SP,[1,,1] ;Flush rest of EVAL blip.
UUOUTX: MOVE T,TSV
MOVE TT,TTSV
JRST @JOBUUO
.UUOTR: EXCH A,UUOTRF# ;Set the UUO TRACE flag.
POPJ P,
SKIPA T,TT
UUOSBR: HLRZ T,(T)
MOVE TT,JOBUUO
HRLI T,(<PUSHJ P,>)
TLNE TT,UUONPB ;UUONPB means no push
TLCA T,34600 ;<PUSHJ P,>xor<JRST>
PUSH P,UUOH
;RWW SOS UUOCAL# ;OLD CODE
;RWW HRRZ R,UUOH ;
SOS R,UUOCAL# ;HANDLES XCT'S STATEMENTS IN UPPER
HLRZ R,(R) ;OF UUOS IN LOWER
CAIE R,(<XCT>)
SKIPA R,UUOCAL
HRRZ R,@UUOCAL
MOVEM R,UUOCAL
IFE ONESEG {
CAIG R,SHRST
JRST .+3
SKIPE WRTSTS
JRST .+3 }
XCT UUOCL
MOVEM T,@UUOCAL
MOVE TT,TTSV
EXCH T,TSV
JRST @TSV
REMOTE<UUOCL: TLNN TT,UUONCB> ;UUONCB means no clobber
UUOS: HRRZ TT,JOBUUO
CAILE TT,@FSBOT
CAIL TT,@FSTOP
JRST UUOSBR-1
JRST UUOEX1
UUOEXP: HLRZ TT,(T)
UUOEX1: LDB T,[POINT 5,JOBUUO,ACFLD]
TRZN T,20
PUSH P,UUOH
PUSH P,TT
JUMPE T,IAPPLY
CAIN T,17
MOVEI T,1
MOVNS T
HRLZ TT,T
PUSH P,A(TT)
AOBJN TT,.-1
JRST IAPPLY
PAGE
ARGPDL: LDB T,[POINT 4,JOBUUO,ACFLD]
MOVNS T
HRLZ R,T
ARGP1: JUMPE R,(TT)
PUSH P,A(R)
AOBJN R,.-1
JRST (TT)
QTIFY: PUSHJ P,NCONS
MOVEI B,CQUOTE(S)
JRST XCONS
QTLFY: MOVEI A,0
QTLFY1: JUMPE T,(TT)
EXCH A,(P)
PUSHJ P,QTIFY
POP P,B
PUSHJ P,CONS
AOJA T,QTLFY1
PDLARG: JRST .+NACS+2(T)
POP P,A+5
POP P,A+4
POP P,A+3
POP P,A+2
POP P,A+1
POP P,A
JRST (TT)
NOUUO: MOVSI B,(<TLNN TT,>)
SKIPE A
MOVSI B,(<TLNA>)
HLLM B,UUOCL
EXCH A,NOUUOF#
POPJ P,
PAGE
;r←0 ←> compiler calling a -
;r←1 ←> compiler calling a lsubr
;r←2 ←> compiler calling f type
UUST: UUOSBR
UUOS1 ;calling l its a subr
UUOS2 ;calling f
UUFST: UUOS9 ;calling - its a f
UUOS10 ;calling l
UUOSBR
UULT: UUOS7 ;calling - its a l
UUOSBR
UUOS8
UUET: UUOEXP
UUOS5 ;calling l its an expr
UUOS6 ;calling f its an expr
UUFET: UUOS3 ;calling - its a fexpr
UUOS4 ;calling l
UUOEXP
UUOS1: HLRZ R,(T)
MOVE T,TSV
JSP TT,PDLARG
JRST (R)
UUOS3: PUSH P,(T)
JSP TT,ARGPDL
UUOS4A: JSP TT,QTLFY
MOVEI TT,1
DPB TT,[POINT 4,JOBUUO,ACFLD]
UUOS6A: POP P,TT
HLRZS TT
JRST UUOEX1
UUOS4: PUSH P,(T)
MOVE T,TSV
JRST UUOS4A
PAGE
UUOS5: HLRZ R,(T)
MOVE T,TSV
JSP TT,PDLARG
MOVNS T
DPB T,[POINT 4,JOBUUO,ACFLD]
MOVE TT,R
JRST UUOEX1
UUOS6: PUSH P,(T)
PUSH P,UUOH
PUSH P,JOBUUO
JSP TT,ILIST
JSP TT,PDLARG
POP P,JOBUUO
POP P,UUOH
JRST UUOS6A
UUOS8: SKIPA TT,CILIST
UUOS7: MOVEI TT,ARGPDL
HRRM TT,UUOS7A
MOVE TT,JOBUUO
TLNN TT,1000
PUSH P,UUOH
HLRZ TT,(T)
JRST @UUOS7A ;OR ILIST
REMOTE<UUOS7A: ARGPDL>
UUOS9: PUSH P,T
JSP TT,ARGPDL
UUS10A: JSP TT,QTLFY
MOVSI T,2000
IORM T,JOBUUO
POP P,T
JRST UUOSBR
UUOS10: PUSH P,T
MOVE T,TSV
JRST UUS10A
PAGE
SUBTTL ERROR HANDLER AND BACKTRACE
;subroutine to print sixbit error message
ERRSUB: MOVSI A,(<POINT 6,0>)
HRR A,JOBUUO
MOVEM A,ERRPTR#
ERRORB: ILDB A,ERRPTR
CAIN A,01 ;conversion from sixbit
POPJ P,
CAIN A,77
JRST [ PUSHJ P,TERPRI
JRST ERRORB]
ADDI A,40
PUSHJ P,TYO
JRST ERRORB
;subroutine to return output to previously selected device
OUTRET: SKIPL PRVCNT ;if prvcnt<0 then there was no device deselect
SOSL PRVCNT ;when prvcnt goes negative, then reselect
POPJ P,
PUSH P,PRVSEL# ;previously selected output
POP P,.TYOD
POPJ P,
;subroutine to force error messages out on tty
ERRIO: MOVE B,ERRSW
CAIE B,INUM0 ;inum0 specifies to print message on selected device
AOSLE PRVCNT ;only if prvcnt already <0 does deselection occur
POPJ P,
TALK ;undo control o
MOVE B,[JRST TTYO]
EXCH B,.TYOD
MOVEM B,PRVSEL
POPJ P,
;ERRTN: 0 ;0 ←> top level *
;- ←> pdl to reset to - stored by errorset
;+ ←> string tyo pout rtn flag
REMOTE<ERRSW: -1> ;0 means no prnt on error *
;subroutine to search oblist for closest function to address in R
ERSUB3: MOVEI A,QST(S)
IFN OLDNIL< HRROI NIL,CNIL2(S)>
IFE OLDNIL< SETZ NIL, >
HRLZ B,INT1
MOVNS B
SETZB AR2A,GOBF
PUSH P,JOBAPR
MOVEI C,[ SETOM GOBF
JRST ERRO2G]
HRRM C,JOBAPR
HRRZ C,VOBLIST(S) ;## GET CURRENT OBLIST
HRRM C,RHX5
HRRM C,RHX2 ;## AND UPDATE LOCATIONS WHICH REF OBLIST
HLRZ C,@RHX5
ERRO2B: JUMPE C,[ AOBJN B,.-1
POP P,JOBAPR ;oblist done, restore
JRST PRINC] ;print closest match
HLRZ TT,(C)
ERRO2C: HRRZ TT,(TT)
JUMPE TT,ERRO2G
HLRZ AR1,(TT)
CAIN AR1,LSUBR(S)
JRST ERRO2H
CAIE AR1,SUBR(S)
CAIN AR1,FSUBR(S)
JRST ERRO2H
HRRZ TT,(TT)
JRST ERRO2C
ERRO2H: HRRZ TT,(TT)
HLRZ TT,(TT)
CAMLE TT,AR2A ;le to prefer car to quote
CAMLE TT,R
JRST ERRO2G
MOVE AR2A,TT
HLRZ A,(C)
ERRO2G: HRRZ C,(C)
JRST ERRO2B
PAGE
;dispatcher for error message uuos
ERROR: MOVEI A,APRFLG
APRENB A, ;enable interupts
LDB A,[POINT 9,JOBUUO,OPFLD] ;get opcode
CAIL A,UUOMIN ;what
CAILE A,UUOMAX ;is it?
JRST ILLUUO ;an illegal opcode
JRST @ERRTAB-UUOMIN(A) ;or LISP error
ERRTAB: ERROR1 ;1 ;ordinary LISP error
ERRORG ;2 ;space overflow error
ERROR2 ;3 ;ill. mem. ref.
STRTYP ;4 ;print error message and continue
ERRORG: SKIPN P,ERRTN ;IF IN ERRSET, RESTORE P TO THAT LEVEL
MOVE P,C2 ;else to top level
TLNN SP,-1 ;Has the SP just overflown ?
HRLI SP,-XTRASP ;Yes. Start using the extra space at top of SPEC PDL.
;; SETOM UUO2# ;$$ AND DON'T ENTER ERRORX***Why not ?? DWP.
ERROR1: SKIPN ERRSW
JRST ERREND ;dont print message, call (err nil)
PUSHJ P,ERRIO ;print message on tty
PUSHJ P,TERPRI
PUSHJ P,ERRSUB ;print the message
JRST ERRBK ;go the backtrace
STRTYP: PUSHJ P,ERRIO
PUSHJ P,ERRSUB ;print message and continue
PUSHJ P,OUTRET
JRST @UUOH
;USER ENTRY TO ERROR HANDLER, PRINTS ARG IF NON-NIL
.ERROR: JUMPE A,ERREND
SKIPN ERRSW
JRST ERREND
PUSHJ P,ERRIO
PUSHJ P,TERPRI
PUSHJ P,PRINC
JRST ERREND
PAGE
ERROR2: HRRZ A,JOBUUO
MOVEI B,[SIXBIT / ILL MEM REF FROM !/]
JRST ERSUB2
ILLUUO: HRRZ A,UUOH
MOVEI B,[SIXBIT / ILL UUO FROM !/]
ERSUB2: SKIPN ERRSW
JRST ERREND ;dont print message
PUSH P,A
PUSH P,B
PUSHJ P,ERRIO
PUSHJ P,TERPRI
PUSHJ P,PRINL2 ;print number
POP P,A
STRTIP (A) ;print message
POP P,R
PUSHJ P,ERSUB3 ;print nearest oblist match
ERRBK:
IFN ALVINE,<
SKIPE BACTRF
PUSHJ P,BKTRC ;print backtrace
>
OUTSTR [ASCIZ /
LAST INPUT: /]
PUSHJ P,PWHERE ;Print out page and line no. of input file, if any.
PUSHJ P,PLSTLN ;...and also the last line read.
PUSHJ P,OUTRET ;return to previous device
ERREND: SETZ A, ;## %CLRBFI USED TO BE HERE(FOR ERR NIL)
;; AOSN UUO2 ;$$NO ERRORX IF OVERFLOW ERROR
;; JRST RERX ;$$BOUNCE BACK TO ERRORX
SKIPE ERRSW ;$$NO ERRORX IF NO MESSAGE
SKIPN RSTSW ;$$NEW *RSET FEATURE...
JRST ERR ;$$IF (*RSET NIL) UNBIND AND GO TO TOP LEVEL
PUSHJ P,TYIGBL ;## CLEAR TTY BUFFER AND SAVE TYPE AHEAD.
MOVEI A,ERRORX(S) ;$$ELSE SET TO CALL ERROR HANDLER
MOVEI B,NIL ;$$CREATE FORM (ERRORX)
CEV: PUSHJ P,CONS ;$$
JRST EVAL ;$$AND EVALUATE IT
ERR: SETZM INHERR ;CLEAR RERX FLAG JUST IN CASE
CAIN A,ERRORX(S) ;$$BOUNCE TO ERRORX IF A←ERRORX
JRST RERX
ERR2: SKIPN ERRTN
JRST LSPRET ;not in an errset, or bad error -- go to top level
MOVE P,ERRTN
ERR1: POP P,B
PUSHJ P,UBD ;unbind to previous errset
POP P,ERRSW
POP P,ERRTN
SKIPN INHERR#
JRST ERRP4 ;and proceed
RERX: SETZM INHERR ;$$ POP TO A BREAK ERRSET
MOVE B,ERRSW
CAIE B,ERRORX(S)
SETOM INHERR
JRST ERR2
ERRSET: PUSH P,PA3
PUSH P,PA4
PUSH P,ERRTN
PUSH P,ERRSW
PUSH P,SP
MOVEM P,ERRTN
HRRZ C,(A)
HLRZ C,(C)
MOVEM C,ERRSW
HLRZ A,(A)
PUSHJ P,EVAL
PUSHJ P,NCONS
SETZM INHERR ;CLEAR RERX FLAG
JRST ERR1
SYSCLR: SETZM BSFLG ;FUNCTION TO MAKE SYSTEM LOOK NEW
SETZM CONSVA ;## RESET CONS COUNT
SETZM GCTIM ;## RESET GC TIME
IFE SAIL,< JRST EXCISE > ;** AJT, SAIL hates EXCISE
IFN SAIL,< POPJ P, > ;** AJT, SAIL hates EXCISE
;error messages
RMERR: MOVE A,T ;$$ BAD READ MACRO, GET THE NAME
PUSHJ P,EPRINT ;$$
ERR1 [SIXBIT /UNDEFINED READ MACRO!/]
BNDERR: PUSHJ P,EPRINT ;$$ATTEMPT TO REBIND NIL OR T
ERR1 [SIXBIT /CANNOT BE RE-BOUND!/]
RPAERR: PUSHJ P,EPRINT ;$$PRINT OUT OFFENDING ITEM
ERR1 [SIXBIT /IS AN ATOM, CAN'T BE RPLACA'D!/]
RPDERR: PUSHJ P,EPRINT ;$$
ERR1 [SIXBIT /CAN'T BE RPLACD'D (NIL OR INUM)!/]
DOTERR: SETZM OLDCH
ERR1 [ SIXBIT /DOT CONTEXT ERROR!/]
UNDFUN: HLRZ A,(AR1)
PUSHJ P,EPRINT
ERR1 [SIXBIT /UNDEFINED FUNCTION!/]
UNBVAR: MOVE A,AR1
MOVEI TT,(P)
HRLI TT,UNBOUND(S)
PUSH SP,TT ;Make up an EVAL-BLIP
PUSH SP,A
PUSHJ P,EPRINT
ERR1 [SIXBIT /UNBOUND VARIABLE - EVAL!/]
NONNUM: ERR1 [SIXBIT /NON-NUMERIC ARGUMENT!/]
NOPNAM: ERR1 [SIXBIT /NO PRINT NAME - INTERN!/]
NOLIST: ERR1 [SIXBIT /NO LIST-MAKNAM!/]
TOMANY: ERR1 [SIXBIT /TOO MANY ARGUMENTS SUPPLIED - APPLY!/]
TOOFEW: ERR1 [SIXBIT /TOO FEW ARGUMENTS SUPPLIED - APPLY!/]
UNDTAC: HRRZ A,(C)
UNDTAG: PUSHJ P,EPRINT
ERR1 [SIXBIT /UNDEFINED FUNCTION - APPLY!/]
SETERR: PUSHJ P,EPRINT ;$$BAD SET OR SETQ
ERR1 [SIXBIT /CAN'T BE SET TO A VALUE - SET OR SETQ!/]
EG1: PUSHJ P,EPRINT
ERR1 [SIXBIT /UNDEFINED PROG TAG-GO!/]
EG2: PUSHJ P,EPRINT
ERR1 [SIXBIT /GO WITH NO PROG!/]
EG3: ERR1 [SIXBIT /RETURN WITH NO PROG!/]
;backtrace subroutine
BKTRC: MOVEI D,-1(P)
MOVN A,BACTRF
ADDI A,INUM0
JUMPL A,[ ADD A,P ;backtrace specific number
JRST .+3]
SKIPN A,ERRTN ;backtrace to previous errset
MOVE A,C2 ;or top level
HRRZM A,BAKLEV#
STRTIP [SIXBIT /←BACKTRACE←!/]
BKTR2: CAMG D,BAKLEV
JRST FALSE ;done
HRRZ A,(D) ;get pdl element
CAIGE A,FS(S)
JUMPN A,.+2 ;this is (hopefully) a true program address
SOJA D,BKTR2 ;not a program address, continue
CAIN A,ILIST3
JRST BKTR1A ;argument evaluation
BKTR1B: CAIN A,CPOPJ
JRST [ HLRZ A,(D) ;calling a function
PUSHJ P,PRINC
XCT "-",CTY
STRTIP [SIXBIT /ENTER !/]
SOJA D,BKTR2]
HLRZ B,-1(A)
CAILE B,(<JCALLF 17,@(17)>)
CAIN B,(<PUSHJ P,>) ;tests for various types of calls
CAIGE B,(<FCALL>)
SOJA D,BKTR2 ;not a proper function call
PUSH P,-1(A) ;save object of function call
MOVEI R,-1(A) ;location of function call
PUSHJ P,ERSUB3 ;print closest oblist match
MOVEI A,"-"
PUSHJ P,TYO
POP P,R
LDB B,[POINT 4,R,18] ;GET INDEX FIELD...
CAIN B,S
MOVEI R,@R
TLNN R,17
HRRZI R,@ERSUB3 ;qst -- cant handle indexed calls
HRRZS R
HLRO B,(R)
AOJE B,[HRRZ A,R ;was calling an atomic function
PUSHJ P,PRINC ;print its name
JRST .+2]
PUSHJ P,ERSUB3 ;was calling a code location -- print closest match
MOVEI A," "
PUSHJ P,TYO
BKTR1: SOJA D,BKTR2 ;continue
BKTR1A: HRRZ B,-1(D)
CAIE B,EXP2
CAIN B,ESB1
JRST .+2
JRST BKTR1B ;hum, not really evaluating arguments
HLRE B,-1(D)
ADD B,D
HLRZ A,-3(B)
JUMPE A,BKTR1
PUSHJ P,PRINC
XCT "-",CTY
STRTIP [SIXBIT /EVALARGS !/]
JRST BKTR1
BAKGAG: EXCH A,BACTRF#
POPJ P,
SUBTTL TYI, ITYI, etc., Tyi and Tyo
ITYI: PUSHJ P,TYI
FIXI: ADDI A,INUM0
POPJ P,
TYI: PUSHJ P,TYIA
TYI.1: JUMPE A,.-1 ;Skip nulls.
CAME A,IGSTRT ;start of comment or ignored cr-lf
POPJ P,
PUSHJ P,COMMENT
JRST TYI.1
WORDIN: SKIPN A,INCH ;Are we doing input from the tty ?
JRST ERR ;Yes. What a stupid loser. Give him (ERR NIL).
SKIPG @TYI2 ;Test count of characters remaining in record.
PUSHJ P,TYI2X ;Read next record.
MOVNI A,5 ;Decrement count. (1 word = 5 chars.)
ADDM A,@TYI2
AOS A,@TYI3 ;Get byte ptr. and increment it to next word.
MOVE A,(A) ;Get data.
POPJ P,
REMOTE {
TYI2: JRST TTYI ;Contains SOSG X for input from device other than TTY.
TYI3: X ;Pointer to the byte pointer for the current channel.
TYI3A: TDNN AR1,@X ;Same addr. as TYI3.
}
TYIA: SKIPE A,OLDCH
JRST TYI1
TYID: XCT TYI2 ;JRST TTYI for TTY input, else SOSG count.
PUSHJ P,TYI2X ;Read next record.
TYI3B: ILDB A,@TYI3 ;pointer
CAIN A,14 ;Is it a form feed ?
JRST [ AOS PGNUM ;Yes. Bump page no.
SETZM LINUM
JRST TYICLN]
CAIN A,12 ;A linefeed ?
TYICLN: AOS LINUM
MOVEI AR1,1
XCT TYI3A ;Is low order bit on ?
JRST TYIXIT ;No.
MOVE A,@TYI3A ;Yes. Assume the word contains an ASCII line number.
; CAMN A,[<ASCII / />+1] ;page mark for stopgap
; AOSA PGNUM ;increment page number
MOVEM A,LINUM
MOVNI A,5
ADDM A,@TYI2 ;adjust character count for line number
AOS @TYI3 ;increment byte pointer over line number and tab
JRST TYID
REMOTE< TYI2X: INPUT X,
HRRZ A,INCH ;!!!RANDOM -- increment record
HRRZ A,CHTAB(A);!!! number for USETx...
AOS A,CHREC(A) ;!!!
TYI2Y: STATZ X,740000
ERR1 AIN.8 ;input error
TYI2Z: STATO X,20000
JRST TYICTST ;continue with file, after checking for E directory.
JRST TYIEOF ;END OF FILE
>;!!!REMOTE
TYIEOF: PUSH P,T ;!!!end of file
TIEOF1: PUSH P,C
PUSH P,R
PUSH P,AR1
MOVE A,INCH
HRRZ C,CHTAB(A) ;!!!get location of data for this channel
HLRZ T,CHTAB(A) ;!!!inlst-- remaining files to input
JUMPE T,TYI2E ;!!!none left -- stop
PUSH P,C
PUSHJ P,SETIN ;!!!start next input
PUSHJ P,ININIT ;## INIT THE FILE
POP P,C
JUMPE A,AIN.7 ;## CAN'T FIND FILE, ERROR
; !!!USERIO 9-73 DCS -- reset iofn name if a FN: channel
MOVE AR1,FNNAME(C);!!!function name
SKIPGE CHNAM(C)
MOVEM AR1,IOFN
POP P,AR1
POP P,R
POP P,C
POP P,T
XCT TYI2 ;Have to do this in case a FN: channel is active.
JRST TYI2X ;Read first record of new file.
POPJ P, ;I don't believe we can ever get to this instr., but ...
;!!! DCS 8-73 RANDOM -- Modifications to end of file code, to release
;!!! both input and output sides of an INOUT channel.
TYI2E: MOVE A,CHNAM(C); If input file, clear input file part!
TRNN A,400000; check it
SETZM INCHAN(C) ; Input file, don't interpret as update
PUSH P,INCHAN(C); input file part, if update file
PUSHJ P,INCNT ;(inc nil t)
POP P,C ; If update file, do (OUTC NIL T)
JUMPE C,ALDNN ; also
PUSHJ P,OUTCNT; (outc nil t) [old file already released by incnt]
TALK ;turn off control o
ALDNN:
MOVEI A,$EOF$(S);we are done
JRST ERR
IFN STANSW,<
;!!! Remove Directory page from E files
TYICTST:SOJN A,CPOPJ ;Check only the first record of a file for an E directory.
COMTST: HRRZ A,@TYI3 ;!!! The first words of an E file
PUSH P,T ;!!! with an invalid directory are:
MOVE T,1(A) ;!!! "COMMENT ⊗ INVALID ..."
CAME T,[ASCII /COMME/] ;!!! This is always the first text in
JRST POPTJ ;!!! a record.
MOVE T,2(A) ;!!!
CAME T,[ASCII /NT ⊗ /] ;!!! This code reads records until the
JRST POPTJ ;!!! next page (which begins with a FF
COMLP: XCT TYI2X ;INPUT ;!!! in char 1 of a record) is found,
XCT TYI2Y ;STATZ ;!!! then continues to read characters.
JRST AIN.8
XCT TYI2Z ;STATO
SKIPA A,@TYI3
JRST TIEOF1 ;End of file.
LDB T,[POINT 7,1(A),6] ;Get first chr. of this record.
CAIE T,14
JRST COMLP ;READ TO FF
POPTJ: POP P,T
POPJ P,
>;!!!STANSW
;!!! USERIO 9-73 DCS -- PRINT and READ use the extension (unused portion) of the
; SP stack to collect atoms, since previous READ/WRITE routines did not use
; this stack. Both routines use register C to record the current address
; (PRINT sometimes uses one more word). FIXSP, called by the TYIFN and TYOFN
; user routine interfaces, saves SP, and updates its current value to point
; beyond the current C, if C looks like it is in this mode (within the
; unused stack portion. The FN routines will restore SP on return.
FIXSP: PUSH P,SP ;Save
HRRZ B,SP ;If the distance between SP and C is
SUBI B,(C) ; positive, and is smaller than the
HLRE C,SP ; distance to the end of the stack area,
JUMPGE B,(AR1) ; update SP to the current value of C.
CAMGE B,C ; (The calculations are carried out using
JRST (AR1) ; the negative values of all the numbers,
MOVNS B ; for convenience when working with stack
ADDI B,1 ; size counts).
HRL B,B
ADD SP,B
JRST (AR1)
;!!! USERIO 9-73 DCS -- TYI interface. When a FN: channel is active for input,
; this routine is called for every TYI. The INC routine has placed the
; atom for the user's routine into IOFN. This routine saves all ACs which
; might get clobbered, calls (USERIO NIL NIL), then returns the first
; character in the PNAME of the resulting (one-character) atom. If
; the atom from the USERIO function is $EOF$, an end of file condition is
; simulated.
TYIFN: HLRE A,P ;Test for enough room to store registers
CAML A,[-R+A] ; B through R
JRST [HRROS P ;No, cause a pdlov
PUSH P,
STRTIP [SIXBIT /PDLOV IN FUNCTION TYI !/]]
HRLI A,B ;BLT B through R onto stack
HRRI A,1(P)
BLT A,R-A(P)
ADD P,[R-A,,R-A]
JSP AR1,FIXSP ;Fix SP as described above.
SETZB A,B ;(IOFN NIL NIL)
CALLF 2,@IOFN# ;Call user getchar routine
POP P,SP ;Restore, tho may not be changed
CAIE A,$EOF$(S) ;If EOF, leave alone
;; MOVEI B,PNAME(S) ;User result is one-char atom, get it's
;; PUSHJ P,GET ; character value
;; HLRZ A,(A)
;; LDB A,[POINT 7,(A),6];Unadorned character code
SUBI A,INUM0 ;Now we use ascii instead of atoms !
TYFN: HRLI R,-R+A+1(P) ;Restore B through R
HRRI R,B
BLT R,R
SUB P,[R-A,,R-A]
CAIN A,$EOF$(S) ;returned if "EOF", never happens with TYO
JRST TYIEOF
POPJ P, ;!!!
REMOTE<
OLDCH: 0
PGNUM: 0
LINUM: 0
0 ;zero to terminate num10
>;!!!REMOTE
;TTYECHO - COMPLEMENTS THE TTY: ECHO BIT AND RETURNS T IF THE ECHO
; IS BEING TURNED ON AND NIL IF IT IS BEING TURNED OFF
; - TAKES NO ARGUMENTS
ECHO: SETO A,
TTYUUO 6,A ;GET STATUS BITS
TLC A,4 ;COMPLEMENT THE ECHO BIT
TTYUUO 7,A ;RESTORE THE BITS
TLNE A,4 ;TEST TO GET FINAL VALUE
JRST FALSE
JRST TRUE
;CLRBFI - CLEARS TTY INPUT BUFFER FOR USER ERRORS
; - 0 ARGS AND RETURNS NIL
%CLRBFI:CLRBFI ;CLEAR BUFFER
SETZM SMAC ;CLEAR SPLICE LIST
SETZM OLDCH ;CLEAR LAST CHAR.
JRST FALSE
ERRCH: MOVEI A,-INUM0(A) ;## CHANGE BELL CHARACTER
EXCH A,ERRCHR ;## RETURN OLD CHARACTER
JRST FIX1A ;## CONVERT IT
REMOTE <
ERRCHR: BELL
>
;teletype input
REMOTE {TYIBUF: BLOCK =50 ;Buffer for saving last line read.
TYISAV: 1 ;Flag saying to save.
TYISVP: POINT 7,TYIBUF
TYISVC: =49*5 ;Chr. count for TYIBUF
TYIGBUF: BLOCK =50 ;Buffer for gobbling type-ahead.
TYIGBF: 0
TYIGBP: 0
TYIGEND: 0
TYIGSYNC: 0
}
TYIGBL: ;Gobble everything in system TTY buffer and save it.
SKIPN INCH ;...but only if input is from TTY...
SKIPGE TYIGSYNC ;...and we are not already in the gobbled state.
POPJ P,
MOVE A,OLDCH ;Set the synchronizer flag (and preserve OLDCH).
HRROM A,TYIGSYNC
SKIPE A,TYIGBF ;Decide where in the gobble buffer to start saving.
JRST TYIGB3 ;Some stuff alread in buffer. Append new stuff.
MOVE A,[POINT 7,TYIGBUF];Buffer empty. Start at beginning.
MOVEM A,TYIGEND
TYIGB3: MOVEM A,TYIGBP ;This ptr. will be used to recover the gobbled chrs.
TYIGB1: INCHRS B
JRST TYIGB2 ;No more input to gobble.
IDPB B,TYIGEND ;Store a gobbled chr.
JRST TYIGB1
TYIGRS: SETZM TYIGSYNC ;Reset the TYIBGL mechanism.
TYIGB2: SETZM OLDCH
SETZM TYIGBF ;TYIGBF means TTYI should eat from gobbled buffer...
POPJ P,
TYIRGB: SKIPL A,TYIGSYNC ;Set TTYI to read the type-ahead saved by TYIGBL.
POPJ P, ;No gobbled stuff to read.
SETZM TYIGSYNC
SKIPN INCH
HRRZM A,OLDCH
MOVE A,TYIGBP
MOVEM A,TYIGBF ;TYIGBF≠0 will cause TTYI to go to TYIGBG.
POPJ P,
TYIGBG: CAMN A,TYIGEND ;We come here from TTYI.
JRST TYIGBX ;End of gobbled stuff. Resume reading from TTY.
ILDB A,TYIGBF ;Recover next gobbled chr.
JRST TTYXIT
TSAVRS: MOVSI D,=30*5 ;Reset the type-in saving mechanism.
MOVSM D,TYISVC
SKIPL TYISVP ;If buffer not empty...
IDPB D,TYISVP ;...mark end of line with a null.
MOVE D,[POINT 7,TYIBUF]
MOVEM D,TYISVP
POPJ P,
TYIAGN: PUSHJ P,TSAVRS ;Let user re-use last line he typed...
PTYUUO 15,[0↔TYIBUF]
AOSA TYISAV ;Resume saving input.
TYINO: SETZM TYISAV ;Stop saving input...
TYIGBX: SETZM TYIGBF ;Stop reading gobbled input (we aren't anyway if we fall in).
TTYI: SKIPE DDTIFG ;Input from keyboard.
JRST TTYID ;Single-char. activation.
SKIPE A,TYIGBF ;Are we reading saved type-ahead ?
JRST TYIGBG
INCHSL A ;single char if line has been typed
JRST [OUTCHR PROMCH# ;$$OUTPUT PROMPT CHARACTER
INCHWL A ;wait for a line
JRST .+1]
CAIN A,200+ALTMOD ;<ctrl> ALTMODE ?
JRST TYINO ;Cease saving input.
CAIN A,600+ALTMOD ;Is it <ctrl><meta>ALTMODE ?
JRST TYIAGN ;Yes.
ANDI A,177
TTYXIT: CAMN A,ERRCHR
JRST TYIERC
TYIXIT: SKIPG TYISAV ; Unless we have seen <ctrl>ALTMODE,
POPJ P, ; store chr. for possible re-use or error message.
TYIX1: SOSG TYISVC ;If buffer is full,
PUSHJ P,TSAVRS ; wrap around.
IDPB A,TYISVP
CAIE A,12
CAIN A,ALTMOD
PUSHJ P,TSAVRS ;Reset the chr. saving mechanism at end of line.
POPJ P,
TYIERC:
IFN ALVINE,{
SKIPE PSAV1# ;bell from alvine?
JRST [ MOVE P,PSAV1 ;yes, return to alvine
JRST @ED1];$$DOUBLY IMPROVED MAGIC
}
MOVEI A,NIL ;$$ RETURN NIL AS THE VALUE
JRST RERX ;$$ RETURN TO AN ERRORX ERRSET
TTYID: INCHRW A ;single character input ddt submode style
CAIE A,RUBOUT
JRST TTYXIT
OUTCHR ["\"] ;echo backslash
SKIPE PSAV
JRST RDRUB ;rubout in read resets to top level of read
MOVEI A,RUBOUT
POPJ P,
PGLINE:
MOVE A,LINUM
TLNE A,-1
PUSHJ P,CLINUM ;(see NUM10) convert ascii line number to a integer
ADDI A,INUM0
MOVE B,PGNUM
ADDI B,INUM0
JRST XCONS
PWHERE: SKIPN A,INCH ;Tell loser where in input file he lost.
POPJ P, ;Input from TTY:
OUTSTR [ASCIZ /File: /]
MOVE A,CHTAB(A)
PUSH P,CHEXT(A)
MOVE A,CHFIL(A)
PUSHJ P,SIXATM ;Make it an atom.
PUSHJ P,TPRIN1
POP P,A
HLLZ A,A ;File extension.
JUMPE A,PPL2
OUTSTR[ASCIZ /./]
PUSHJ P,SIXATM
PUSHJ P,TPRIN1 ;!!!! TPRIN1 WILL LEAVE R SET UP TO .TTYO FOR PRINI3 !!!
PPL2: MOVEI C,=10 ;Output radix.
OUTSTR [ASCIZ / Page /]
MOVE A,PGNUM ;Print page no.
PUSHJ P,PRINI3 ;!!! R BETTER CONTAIN .TTYO STILL !!!
OUTSTR [ASCIZ / Line /]
PUSHJ P,PGLINE ;Get (page.line).
MOVEI A,-INUM0(B) ;This depends on CONS leaving the pair in B...
MOVEI C,=10 ;Radix.
PUSHJ P,PRNTINT ;Line no. !!! R BETTER CONTAIN .TTYO STILL !!!
OUTSTR [BYTE (7)15,12] ;CR-LF
MOVEI A,12 ;Place a LINE FEED in the input saving buffer, and
IDPB A,TYISVP ; then `read' to end of line so that the whole line
MOVE C,@TYI2 ; will be displayed by OUTSTR TYIBUF, with a LINE
MOVE B,@TYI3 ; FEED just after where the error occured.
PPL3: ILDB A,B ;We `read' the rest of line without changing the byte
PUSHJ P,TYIX1 ; pointer or count in core.
SKIPL TYISVP ;Did TYIX1 see a LINE FEED ?
SOJGE C,PPL3 ;No, but don't go past end of record.
POPJ P,
PLSTLN: PUSHJ P,TSAVRS ;(This is redundant unless input is from TTY.)
OUTSTR TYIBUF ;Type out the last line read.
POPJ P,
PROMPT: SKIPN A
SKIPA A,PROMCH
MOVEI A,-INUM0(A) ;$$CHANGE FROM INUM
EXCH A,PROMCH# ;$$CHANGE PROMPT CHARACTER AND RETURN OLD ONE
JRST FIXI
INTPRP: SKIPN A
SKIPA A,LSPRMP
EXCH A,LSPRMP# ;$$ EXCHANGE FOR OLD TOP LEVEL PROMPT
POPJ P, ;$$
READP: SKPINC ;$$ T IFF A CHARACTER HAS BEEN TYPED
JRST FALSE ;$$ (DOES NOT CHECK OLDCH)
JRST TRUE
UNTYI: MOVEI B,-INUM0(A) ;$$ UN-READ A CHARACTER (PUT IT IN OLDCH)
MOVEM B,OLDCH
POPJ P, ;$$ RETURN ARG AS VALUE
;TYO, TTYO, etc., Tyo
ITYO: SUBI A,INUM0
PUSHJ P,TYO
JRST FIXI
.TYO: CAIG A,CR
JRST TYO3
TYO69: SOSGE CHCT
JRST TYO1
JRST .TYOD
REMOTE<.TYOD: JRST .TTYO+X ;sosg x for other device
;other device output
JRST TYO2X
TYO5: IDPB A,X
POPJ P,
TYO2X: OUT X,
JRST TYO5
ERR1 [SIXBIT /OUTPUT ERROR!/]
>;!!!REMOTE
TYO1: PUSH P,A ;linelength exceeded
MOVE A,IGSTRT ;ignored cr-lf
PUSHJ P,.TYOD
PUSHJ P,.TERPRI ;force out a cr-lf, with special mark
POP P,A
SOSA CHCT
TYO4: POP P,B
JRST .TYOD
TYO3: CAIGE A,TAB
JUMPN A,TYO69 ;everything between 0(null) and 11(tab) decrement chct
PUSH P,B
MOVE B,LINL
CAIN A,TAB
JRST [ SUB B,CHCT
IORI B,7 ;simulate tab effect on chct
SUB B,LINL
SETCAM B,CHCT
JRST TYO4]
CAIN A,CR
MOVEM B,CHCT ;reset chct after a cr
JRST TYO4
;!!! USERIO 9-73 DCS -- TYO interface. When a FN: channel is active for output,
; this routine is called for every TYO. The OUTC routine has placed the
; atom for the user's routine into IOFN. This routine saves all ACs which
; might get clobbered, calls (USERIO T CHAR), where CHAR is a one-character
; atom created from the character to be written. It ignores the result of
; the value returned from the USERIO routine, instead returning its input
; (A).
TYOFN: PUSH P,B ;NEED B, SAVE FIRST
HLRE B,P ;Test for enough room to store registers
CAML B,[-R+A+1] ; B through R
JRST [HRROS P ;No, cause a pdlov
PUSH P,
STRTIP [SIXBIT /PDLOV IN FUNCTION TYO !/]]
HRLI B,C ;BLT B through R onto stack
HRRI B,1(P)
BLT B,R-A-1(P)
ADD P,[R-A-1,,R-A-1]
JSP AR1,FIXSP ;See prev. page, fix up SP
CAMN SP,(P) ;If SP was adjusted, move it out to
JRST NOSPA ; the first zero word, since PRINN
MOVE B,SP
SKIPE (B) ; has pushed data, then a [0], into the
AOBJN B,.-1 ; unused area of the stack, for printing.
JUMPGE B,NOSPA
MOVE SP,B ;(Don't exceed size of stack)
NOSPA: PUSH P,A ;Save result to return
;; PUSHJ P,AASC1 ;One-char ATOM to User FN.
ADDI A,INUM0 ;Just pass ascii for char.
MOVEI B,TRUTH(S) ;(IOFN CHAR T) for output
EXCH A,B
CALLF 2,@IOFN ;User fn
POP P,A ;Non-atomized input
POP P,SP ;Restore old stack.
JRST TYFN ;!!! Finish up in common code
LINELENGTH:
JUMPE A,LINEL1
SUBI A,INUM0
IFN STANSW,< ;!!! WHY THE CHANGE IN LINELENGTH DEF?
MOVEM A,CHCT
EXCH A,LINL
JRST FIXI
LINEL1: MOVE A,LINL
>;!!!STANSW
IFE STANSW,<
HRRM A,LINL
HRRM A,CHCT
LINEL1: HRRZ A,LINL
>;!!!NOT STANSW
JRST FIXI
SETIGCRLF: ;Set ignored crlf char. and return old value.
SUBI A,INUM0 ;Takes ASCIIVAL of new char.
EXCH A,IGSTRT
JRST FIXI
CHRCT: MOVE A,CHCT
JRST FIXI
REMOTE<
LINL: TTYLL
CHCT: TTYLL
>;!!!REMOTE
;!!! 8-73 DCS PRINT -- Buffered tty output.
; WARNING is the last word of the tty buffer. It is zeroed after every
; OUTSTR writes the buffer. When a character is DPBed into it, its
; non-zero value serves as an indication that the buffer is nearly full,
; and output is forced. This happens during a call to .TYO, which is
; ultimately responsible for ALL tty output.
; FORCE is called to OUTSTR any characters written by the current high-
; level (undotted) print routine. It forces characters unless (BUFFER T)
; is in effect.
;teletype output
.TTYO: IDPB A,TTYPNT ;OUTPUT SINGLE CHARACTER IN A
SKIPE WARNING ;BUFFER OVERFLOWING?
FORCE: SKIPE OUTCH ;TTY OUTPUT?
POPJ P, ; NO
SKIPN WARNING ;DON'T FORCE YET IF BUFFERING UNLESS
SKIPN BUFFLG ; OVERFLOWN
JRST .+2
POPJ P,
XFORCE: PUSH P,A
MOVEI A, ;MAKE SURE IT'S ASCIZ
IDPB A,TTYPNT
OUTSTR TTYBUF ;TYPE CURRENT BUFFER
FORST1: SETZM WARNING ;NO OVERFLOW NOW
MOVE A,[POINT 7,TTYBUF] ;RESET
MOVEM A,TTYPNT
JRST POPAJ
FORSET: PUSH P,[0]
SETZM BUFFLG
JRST FORST1
;!!! (BUFFER T) inhibits output until buffer overflow or next (BUFFER NIL).
; (BUFFER NIL) forces waiting output, and allows normal FORCing.
; BUFFER returns previous flag value.
BUFFER: EXCH 1,BUFFLG ;REPLACE AND RETURN
JRST FORCE
REMOTE< ;!!! DATA FOR TTY OUTPUT BUFFERING
BUFFLG: 0 ;IF T, TTY OUTPUT GOES OUT ONLY ON OFLOW
TTYPNT: POINT 7,TTYBUF
TTYBUF: BLOCK =29
WARNING: 0 ;WHEN THIS FILLS, TIME TO DUMP
>;!!!REMOTE
REMOTE<DDTIFG: TRUTH>
DDTIN: EXCH A,DDTIFG
POPJ P,
TTYRET: PUSHJ P,OUTCNT
JRST INCNT
;THIS IS THE NEW, FAST, AND SHORT ROUTINE TO TURN OFF CONTROL O
TTYCLR: INCHSL FOOGG# ;;DWP;;SKPINL ;## SKPINL FIXES RUBOUT PROBLEM IN TYPE AHEAD
JFCL
POPJ P,
REMOTE<
TTOCH: 0
IFN STPGAP,<
0 ;tty page number always zero
0 ;tty line number -- always zero
>
TTOLL: TTYLL
TTOHP: TTYLL>
SUBTTL Input and Output Initialization and Control -- SIXMAK, NEXTIO, SIXRT
;convert an ATOM to sixbit for device initialization routines
SIXMAK: PUSH P,C ;!!!save channel table pointer
SETZM SIXMK2#
MOVE AR1,[POINT 6,SIXMK2]
HRROI R,SIXMK1
PUSHJ P,PRINTA ;use print to unpack ascii characters
MOVE A,SIXMK2
POP P,C ;!!!
POPJ P,
;!!! Improved sixbit routine handles lower case
SIXMK1: TRZE A,100 ;COPY 100 BIT TO 40 BIT
TROA A,40
TRZ A,40
TLNN AR1,770000
POPJ P, ;last character position -- ignore remaining chars
CAIN A,'.'
MOVEI A,0 ;ignore dots at end of numbers for decimal base
CAIN A,':'
HRLI AR1,(<POINT 6,0,29>) ;deposit : in last char position
IDPB A,AR1
POPJ P,
;subroutine to process next item in file name list
INXTIO: JUMPE T,NXTIO
HRRZ T,(T)
NXTIO: HLRZ A,(T)
PUSHJ P,ATOM
JUMPE A,CPOPJ ;non-atomic
HLRZ A,(T)
JRST SIXMAK ;make sixbit if atomic
;right normalize sixbit
SIXMRT: PUSHJ P,SIXMAK
SIXRT: TRNE A,77
POPJ P,
LSH A,-6
JRST SIXRT
;IOSUB AND FRIENDS (CHNSUB,DEVCHK)
;## SUBROUTINE TO TEST FOR A DEVICE OR QUEUE. USED BY I/O ROUTINES
;## AND THE QUEUE ROUTINES. LEAVES A←0 IF NOT AN ATOM AND B←0
;## DEVICE OR QUEUE.
DEVCHK: PUSHJ P,NXTIO ;## MAKE SIXBIT IF AN ATOM
LDB B,[POINT 6,A,35];## GET LAST CHAR
CAIN B,':' ;## DEVICE?
TRZA A,77 ;## YES, CLEAR CHAR BUT LEAVE B INTACT
SETZ B, ;## NO, CLEAR B
POPJ P, ;## DONE, IF A←0 OR B←0, NOT A DEVICE
;## SUBROUTINE TO PARSE THE I/O SPECIFICATION. DEFAULT IS DSK IF
;## NO DEVICE SPECIFIED.
IOSUB: MOVEM T,DEVDAT# ;## SAVE ARG FOR ERRORS
SKIPE DEV ;## DEVICE ALREADY SPECIFIED?
JRST .+4 ;## YES, FORGET DEFAULT
SETZM PPN ;## CLEAR PPN
MOVSI A,'DSK' ;## STORE DSK AS DEFAULT
MOVEM A,DEV
PUSHJ P,DEVCHK ;## SEE IF DEVICE SPECIFIED
JUMPE A,IOPPN ;## NON-ATOMIC ARG, MUST BE PPN OR (FILE.EXT)
JUMPE B,IOFIL ;## NOT A DEVICE, MUST BE FILE NAME
SETZM PPN
IODEV2: MOVEM A,DEV
;!!! USERIO 9-73 DCS-- detect device FN:, set CHNAM entry for channel negative.
;!!! That is the signal for detecting USERIO throughout the other operations.
MOVSI B,400000;!!!device "FN:" means user function does "input"
CAMN A,[SIXBIT /FN/]
HLLM B,CHNAM(C) ;!!!NEGATIVE CHNAM ENTRY FOR FN:
PUSHJ P,INXTIO
IOPPN: JUMPN A,IOFIL ;not ppn or (fil.ext)
PUSHJ P,PPNEXT
JUMPN A,IOEXT ;(fil.ext)
HLRZ A,(T)
PUSHJ P,CNVPPN ;## CONVERT PPN
MOVEM A,PPN
HRLZI A,(<SIXBIT /DSK/>) ;disk is assumed
JRST IODEV2
IOFIL: JUMPN A,IOFIL2 ;was it an atom
JUMPE T,CPOPJ ;no, was it nil (end)
PUSHJ P,PPNEXT
JUMPE A,CPOPJ ;see a ppn, no file named
IOEXT: HLRZ A,(T) ;(file.ext)
HRRZ A,(A) ;get cdr ←← extension
PUSHJ P,SIXMAK
HLLM A,EXT
HLRZ A,(T)
HLRZ A,(A) ;get car ← file name
PUSHJ P,SIXMAK
FIL: PUSH P,A
PUSHJ P,INXTIO
JRST POPAJ
IOFIL2: CAIN B,":"-40
POPJ P, ;saw a :,not file name
SETZM EXT ;file name -- clear extension
JRST FIL
PPNEXT: JUMPE T,CPOPJ ;end of file name list
HLRZ A,(T)
HRRZ A,(A) ;cdar
JRST ATOM ;ppn iff (not(atom(cdar l)))
CHNSUB: MOVE T,A
HLRZ A,(T)
PUSHJ P,ATOM
JUMPE A,TRUE ;non-atomic head of list -- no channel named
HLRZ A,(T)
PUSHJ P,SIXMAK
ANDI A,77
CAIN A,":"-40
JRST TRUE ;device name, assume channel name t
HLRZ A,(T) ;channel name -- return it
TRZ A,400000 ;If the idiot uses an INUM, this will prevent it from
HRRZ T,(T) ;looking like an output channel automatically.
POPJ P,
;## LEFT HALF OF A CHANNEL TABLE ENTRY IS THE REMAINING
;## FILE LIST. RH POINTS TO EXTENDED HEADER.
;Channel table definitions
REMOTE<
CHTAB←.-FSTCH
BLOCK NIOCH
>;!!!REMOTE
;channel data
CHNAM←←0 ;name of channel I/O
;!!USERIO 9-73 DCS -- LH negative (400000) for USERIO channel.
CHDEV←←1 ;name of device I/O
CHPPN←←2 ;ppn for input channel I/
CHLL←←2 ;linelength for output channel /O
CHOCH←←3 ;oldch for input channels I/
CHHP←←3 ;hposit for output channels /O
;!!! IFN STOPGAP not worth the savings any more (my opinion) DCS
CHPAGE←←4 ;page number for input I/
INCHAN←←4 ;input buffer info pointer for update /O
CHLINE←←5 ;line number for input
; RANDOM 8-73 DCS
CHREC←←6 ;record number for USETI/USETO
CHFIL←←7 ;filename
CHEXT←←10 ;extension
CHDAT←←11 ;device data
; USERIO 9-73 DCS
FNNAME←←11 ;function name, for functionally simulated input (FN:)
POINTR←←12 ;byte pointer for device buffer
COUNT←←13 ;character count for device buffer
BLKSIZE←←NIOB*MLIOB+COUNT+1
; DCS 8-73 RANDOM -- INOUT channel table entries look mostly like
; OUTPUT channel entries. The exception is that the INCHAN
; (a new) entry is non-null for INOUT. It is a pointer to
; the channel table entry for the corresponding input side
; of the channel. The stored names are related in the usual
; way, with the output file name 400000 greater than the
; input name. Special code in TTY input EOF, (INC ... T),
; and (OUTC ... T) take care of releasing both blocks, the
; latter to a special list of INOUT input blocks.
; Additionally, code in INPUT, OUTPUT, and support routines were
; changed to accommodate calls from INOUT, to set up this beast.
; A much cleaner design would result from a rewrite of the whole
; section.
;!!!
;search for channel name in chtab
;!!!modified for USERIO feature
TABSR1: MOVE A,[XWD -NIOCH,FSTCH]
PUSH P,AR1
MOVE C,CHTAB(A)
HRRZ AR1,CHNAM(C)
CAME B,AR1
AOBJN A,.-3
CAME B,AR1
MOVEI A,NIL ;DIDN'T FIND, NIL
POP P,AR1
POPJ P,
;search for channel name in chtab, and if not there find a free channel, and
;if no free channel, allocate a new buffer and channel
TABSRC: MOVE B,A
PUSHJ P,TABSR1
JUMPN A,DEVCLR ;found the channel
PUSH P,B
HRRZ B,NIL ;;;DWP MOVE B,0
PUSHJ P,TABSR1 ;find a physical channel no. for a free channel
JUMPE A,[ERR1 [SIXBIT $NO I/O CHANNELS LEFT !$]]
POP P,B
JUMPN C,DEVCLR ;found free channel which had buffer space previously
NEEDMR: PUSH P,A ;must allocate new buffer
MOVEI A,BLKSIZ
SETZ D, ;SPECIAL RELOCATION - SEE LOAD
PUSHJ P,MORCOR ;expand core for buffer if necessary
MOVE C,A
POP P,A
DEVCL1: HRRM C,CHTAB(A)
DEVCLR: HRRZ C,CHTAB(A)
HRRZM B,CHNAM(C) ;store name
HRRZM A,CHANNEL#
POPJ P,
;subroutine to reset all i/o channels -- used by excise and realloc
IOBRST:
IFE SAIL { ;If we are getting free stg. from SAIL, forget this.
SKIPN A,PRGBRK ;Any code at top of core ?
HRRZ A,JRELO ;No, so jrelo is highest used loc.
HRLM A,JOBSA
MOVEM A,CORUSE}
RESET ;Make sure system doesn't think the buffers still there.
SETZM CHTAB+FSTCH
MOVE A,[XWD CHTAB+FSTCH,CHTAB+FSTCH+1]
BLT A,CHTAB+NIOCH+FSTCH-1 ;clear channel table
SETZM SAVIOB(S) ;Flush any saved INOUT buffers.
JRST (R)
;INPUT, ISFILE, RENAME
INPUT1: PUSHJ P,CHNSUB ;determine channel name
MOVEI AR1,(A) ;## SAVE CH NAME
EXCH AR1,(P) ;## EXHANGE WITH RETURN ADDR
PUSH P,AR1 ;## AND STUFF THE RETURN ADDR. IN
INPUT2: PUSHJ P,TABSRC ;## GET PHYSICAL CHANNEL NUMBER
HRRZM A,CHANNEL ;## SAVE IT
SETZM DEV ;## CLEAR DEV SO THAT WE CAN DEFAULT IF APPROPRIATE
JRST SETIN1 ;## SET UP FOR INITIALIZTION
INPUT: PUSHJ P,INPUT1
PUSHJ P,ININIT
INFAIL: JUMPE A,AIN.7 ;## CAN'T FIND FILE
JRST POPAJ
BINPUT: PUSHJ P,INPUT1 ;## IMAGE BINARY INPUT
PUSHJ P,BNINIT
JRST INFAIL
ISFILE: JUMPE A,ISFIL1 ;## ROUTINE TO TELL USER IF A FILE EXISTS
PUSH P,A ;## SAVE A IF NON-NIL
MOVEI A,(B) ;## GET THE FILE NAME
PUSHJ P,NCONS ;## (FILNAM)
POP P,B ;## GET THE DEVICE BACK
ISFIL1: PUSHJ P,XCONS ;## (DEV FILNAM) OR (FILNAM) WHEN HERE
PUSH P,A ;## SAVE IT FOR RETURN
PUSHJ P,RENSUB ;## SEE IF IT'S THERE
PUSH P,A ;## SAVE THE ANSWER
PUSHJ P,RENCLR ;## CLEAR THE CHANNEL
POP P,A ;## ANSWER IN A
JUMPN A,POPAJ ;## IF NON-NIL, THEN IT'S THERE
JRST POPBJ ;## POP ANSWER OFF AND RETURN NIL
RENSUB: MOVEM A,DEVDAT ;## SAVE IT FOR ERROR MSGS
PUSHJ P,GENSYM ;## DON'T CLOBBER CURRENT CHANNELS
MOVE T,DEVDAT ;## GET IT BACK
PUSHJ P,INPUT2 ;## SET UP AND OPEN
JRST ININIT ;## AND INIT
RENAME: PUSHJ P,RENSUB ;## RENAME SETUP
JUMPE A,RENCLR ;## NIL IF CAN'T FIND FILE
PUSHJ P,SETINA ;## PROCESS THE NEW NAME
XCT RNAME ;## EXECUTE
JRST RENCLR ;## RETURN NIL IF FAILURE
PUSHJ P,RENCLR ;## CLEAR CHANNEL
JRST TRUE ;## AND RETURN T IF GOOD
REMOTE <
RNAME: RENAME X,LOOKIN ;## RENAME FILE
>
DELERR: PUSHJ P,AIOP
PUSHJ P,RENCLR ;## KILL THE CHANNEL
ERR1 [SIXBIT /CAN'T DELETE FILE !/]
DELETE: PUSHJ P,RENSUB ;## FIRST SETUP(ALLOWS DEFAULT TO DSK:)
JRST .+2 ;## ALREADY INIT'ED
DELET1: PUSHJ P,ININIT ;## INIT AND LOOKUP
JUMPE A,DELET2 ;## IF FILE NOT THERE IGNORE
SETZM LOOKIN ;## BLAST FILE NAME
SETZM EXT ;## AND EXTENSION
XCT RNAME ;## AND RENAME OUT OF EXISTENCE
JRST DELERR ;## RENAME FAILURE
DELET2: JUMPE T,RENCLR ;## DONE
MOVEM T,DEVDAT ;## SAVE REST OF LIST FOR MSGS.
PUSHJ P,SETINA ;## PROCESS NEXT FILE
JRST DELET1 ;## AND DO IT AGAIN
RENCLR: PUSH P,CHANNEL ;## CLEAR CHANNEL
SETO B, ;## FAKE (INC RENCHANNEL T)
PUSHJ P,IOSEL ;## RELEASE THE CHANNEL
JRST POPAJ ;## RETURN NIL (IOSEL CHANGED THINGS)
;## TO LOOK UP A UFD FOR DIRECTORY FNS. SUBR
UFDINP: PUSH P,A
MOVEI T,(B)
PUSHJ P,TABSRC
HRRZM A,CHANNEL ;## HAVE A CHANNEL
MOVE A,[XWD 'DSK','UFD']
HRLZM A,EXT
HLLZM A,DEV
SETZ B,
AOBJP B,.+1 ;## UFD'S SHOULD BE ON [1,1]
MOVEM B,PPN
SKIPN A,T
PUSHJ P,MYPPN ;## IF B←NIL, DEFAULT TO USER'S PPN
MOVEM A,DEVDAT
PUSHJ P,CNVPPN ;## CONVERT PPN
SETZ T, ;## ZAP T (NO MORE FILES)
PUSHJ P,SETIN2 ;## SETUP
PUSHJ P,BNINIT ;## INIT AS BINARY
JUMPE A,ERR ;## ERR NIL IF NOT THERE
PUSHJ P,ININBF ;## SET UP BUFFERS
JRST POPAJ ;## RETURN CHANNEL
MYPPN: DSKPPN A, ;## GET PPN
PUSH P,A
TRZ A,-1
PUSHJ P,SIXATM
EXCH A,(P)
HRLZ A,A
PUSHJ P,SIXATM
PUSHJ P,NCONS
JRST POPBXC ;## (PROJ PRGRM)
CNVPPN: ;;MOVS A,(A) ;## ASSUME PPNS INUMS
;; HRRI A,-INUM0(A) ;## LH←CDR, RH←CAR
;; MOVSS A ;## SWAP HALVES
;; HLR A,(A) ;## RH←CADR NOW
;; HRRI A,-INUM0(A)
PUSH P,(A) ;;;DWP Stanford PPN's are sixbit.
HLRZ A,(P) ;Get CAR.
PUSHJ P,SIXMRT
EXCH A,(P) ;Save prjn
HLRZ A,(A) ;Get CADR.
PUSHJ P,SIXMRT
HRLM A,(P) ;Combine prjn with prgn.
MOVSS (P)
JRST POPAJ
SETINA: MOVE A,CHANNEL ;## FOR ROUTINES THAT PROCESS MORE
HRRZ C,CHTAB(A) ;## AND KEEP THE CHANNEL IN CHANNEL
SETIN: HRRZM A,CHANNEL
MOVE A,CHDEV(C)
MOVEM A,DEV
MOVE A,CHPPN(C)
MOVEM A,PPN
SETIN1: PUSHJ P,IOSUB ;get device and file name
SETIN2: MOVEM A,LOOKIN ;file name
MOVE B,CHANNEL
HRLM T,CHTAB(B) ;save remaining file name list
DPB B,[POINT 4,ININIX,ACFLD] ;set up channel numbers
DPB B,[POINT 4,BNINIT,ACFLD] ;## FOR IMAGE BINARY
DPB B,[POINT 4,RNAME,ACFLD] ;## FOR RENAME
DPB B,[POINT 4,INLOOK,ACFLD]
DPB B,[POINT 4,ININBF,ACFLD]
HRRZ B,CHTAB(B)
; DCS USERIO 9-73 -- record "file name" -- which is, in this case just
; an atom -- in the data for the "file", for user i/o channels. This
; will be wiped out in the INBUF, for non-USERIO channels (device not FN:).
SKIPL CHNAM(B) ;!!!
MOVEI A,0 ;!!!
MOVEM A,CHDAT(B) ;!!!
MOVE A,DEV
MOVEM A,BDEV ;## ALLOW IMAGE BINARY MODE
SKIPGE CHNAM(B) ;Is this a userio chan ?
JRST SETINX ;Yes.
CALLI A,DEVCHR
TLNN A,INB
JRST AIN.2 ;not input device
TLNN A,AVLB
JRST AIN.4 ;not available
SETINX: MOVEI A,CHDAT(B)
HRRM A,DEV1 ;pointer to bufdat
MOVEM A,BDEV1 ;## IMAGE BINARY MODE
POPJ P, ;## SET UP FOR INITIALIZTION
REMOTE<
BNINIT: INIT X,13 ;## INIT DEVICE IN IMAGE BINARY
BDEV: X
BDEV1: X
JRST AIN.7 ;## CAN'T INIT
JRST INITOX
ININIT: SKIPGE CHNAM(B) ;A real device ?
JRST IRET1 ;No, a userio channel.
ININIX: INIT X,
DEV: X
DEV1: X
JRST AIN.7 ;cant init
INITOX:
MOVE A,PPN ;Restore PPN for subsequent ENTER in case of INOUT.
INLOOK: LOOKUP X,LOOKIN
JRST FALSE ;## LET SOMEONE ELSE HANDLE THE ERROR
MOVEM A,PPN
JRST IRET1>
IRET1:
PUSH B,DEV
PUSH B,PPN
PUSH B,[0] ;oldch
PUSH B,[1] ;page number
PUSH B,[1] ;line number
PUSH B,[0] ;!!!RECORD NO.
PUSH B,LOOKIN ;FILENAME
PUSH B,EXT ;FILENAME EXTENSION
ADDI B,4 ;Altogether COUNT words used here.
HRRM B,JOBFF
SKIPGE CHNAM-COUNT-1(B)
JRST TRUE
JRST ININBF
REMOTE<
ININBF: INBUF X,NIOB
JRST TRUE ;## RETURN FROM GOOD LOOKUP WITH T
ENTR:
LOOKIN: BLOCK 4
EXT←LOOKIN+1
PPN←LOOKIN+3
>
;OUTPUT
OUTPUT: PUSHJ P,CHNSUB ;get channel name
PUSH P,A
TRO A,400000 ;set bit for output
PUSHJ P,TABSRC ;get physical channel nuber
SETZM DEV ;Default device is own DSK area.
PUSHJ P,IOSUB ;get device and file name
MOVEM A,ENTR ;file name
; DCS USERIO 9-73 -- record "file name" -- which is, in this case just
; an atom -- in the data for the "file", for user i/o channels. This
; will be wiped out in the OUTBUF, for non-USERIO channels (device not FN:).
SKIPL CHNAM(C) ;!!!
MOVEI A,0 ;!!!
MOVEM A,CHDAT(C);!!! if FN: device
SETZM ENTR+2 ;zero creation date
MOVE A,CHANNEL
DPB A,[POINT 4,AOUT2,ACFLD] ;setup channel numbers
DPB A,[POINT 4,OUTENT,ACFLD]
DPB A,[POINT 4,OUTOBF,ACFLD]
MOVEI A,CHDAT(C)
HRLM A,AOUT3+1
; DCS USERIO 9-73 -- above and below reorganized, tests inserted to avoid
; INIT, ENTER, OUTBUF for USERIO channels.
SKIPGE CHNAM(C)
JRST OUTP1
MOVE A,DEV
MOVEM A,AOUT3
CALLI A,DEVCHR
TLNN A,OUTB
JRST AOUT.2 ;not output device
TLNN A,AVLB
JRST AOUT.4 ;not available
JRST AOUT2
REMOTE <
AOUT2: INIT X,
AOUT3: X
X
JRST AOUT.4 ;cant init
JRST OUTP1
>;!!!REMOTE
; DCS 8-73 RANDOM -- In A, for INOUT, is input file BUFDAT pointer
OUTP1: MOVEI A,0 ;no update
INOENT: PUSH C,DEV
PUSH C,[LPTLL] ;linelength
PUSH C,[LPTLL]
PUSH C,A ;DCS 8-73 RANDOM -- potential input bfr. ptr.
PUSH C,[0] ; ?
PUSH C,[0] ;RECORD #, FOR USETI/USETO
PUSH C,ENTR ;FILENAME
PUSH C,ENTR+1 ;EXTENSION
ADDI C,4 ;DCS 8-73 RANDOM
HRRM C,JOBFF
SKIPGE CHNAM-COUNT-1(C);DONE, IF "FN:"
JRST POPAJ
JRST OUTENT
REMOTE <
OUTENT: ENTER X,ENTR
JRST OUTERR ;cant enter
OUTOBF: OUTBUF X,NIOB
JRST POPAJ
>;!!!REMOTE
OUTERR: PUSHJ P,AIOP
LDB A,[POINT 3,ENTR+1,35]
CAIE A,2
ERR1 [SIXBIT /DIRECTORY FULL !/]
ERR1 [SIXBIT /FILE IS WRITE PROTECTED !/]
;INOUT
; DCS 8-73 RANDOM -- New routines: INOUT, USETI, USETO
INOUT:
SKIPN B,SAVIOB(S) ;First get a buffer for the output
JRST [PUSH P,A ; part, either from a list of same,
MOVEI A,BLKSIZ ; or from new core -- this will
MOVEI D,0 ;Random parameter to movcor !
PUSHJ P,MORCOR ; replace the input core obtained
MOVE C,A ; from INPUT below, and the latter's
EXCH A,(P) ; buffer will be stored back in
JRST INOUT1] ; SAVIOB list later.
HLRZ C,(B) ;There were some: CDR the list, and
HRRZ B,(B) ; take the CAR.
MOVEM B,SAVIOB(S)
PUSH P,C ;Save output buffer and data block
INOUT1: MOVEI B,CHDAT(C) ;Prepare buffer header (output) for
HRLM B,DEV+1 ; INPUT's INIT, then do
PUSHJ P,INPUT ; (INPUT CHANNEL FILE)
SETZM DEV+1 ; (NEXT INPUT FUNNY ELSE)
PUSH P,A ;FINAL result, for later
MOVE A,CHANNEL ;Now set ENTER and OUTBUF instrs
DPB A,[POINT 4,OUTENT,ACFLD]
DPB A,[POINT 4,OUTOBF,ACFLD]
MOVE T,CHTAB(A) ;The INPUT buffer and data block,
TLNE T,-1 ; verify that there's but one file.
JRST [ERR1 [SIXBIT /CAN ONLY UPDATE ONE FILE!/]]
MOVE B,CHNAM(T) ;Now set up to fill previously
TRO B,400000 ; obtained output data block
MOVE C,-1(P) ;This is it
PUSHJ P,DEVCL1 ;Set name in block, set CHTAB ent.
DOENT: MOVE A,T ;A is input buffer pointer.
POP P,-1(P) ;Zap the old saved buffer ptr.
JRST INOENT ;Finish setting up output, store
; A somewhere in B.
;USETI, USETO, CHSETI, CHSETO
USETI: PUSHJ P,INISET
INFTST: JUMPE T,FIX1A
JUMPL T,[ERR1 [SIXBIT /NON-NUMERIC ARGUMENT -- USETX !/]]
PUSHJ P,INPTST
RESREC: HRRM T,CHREC(C)
JRST FIX1A
USETO: PUSHJ P,INISET
JUMPE T,FIX1A
PUSHJ P,OPTST1
JUMPG T,SETO
XCT .UGETF
PUSHJ P,OPTST1
JRST RESREC
SETO: PUSHJ P,OPTST2
JRST RESREC
REMOTE<
.UGETF: UGETF X,T>;!!
CHSETI: PUSHJ P,INISET
PUSHJ P,CALCHR
JUMPLE T,INFTST
PUSHJ P,INPTST
CHRQUT: MOVNM TT,COUNT(AR1)
ADDM AR2A,POINTR(AR1)
JRST RESREC
CHSETO: PUSHJ P,INISET
MOVE AR1,C
PUSHJ P,CALCHR
JUMPLE T,INFTST
PUSHJ P,OPTST1
HRRZ AR1,INCHAN(C)
JUMPE AR1,NSETIN
PUSHJ P,INPTS1
TRNE B,20000
MOVEI AR1,0
NSETIN: PUSHJ P,OPTST2
JUMPE AR1,CHOQUT
HRRZ B,CHDAT(C)
HRL B,CHDAT(AR1)
ADD B,[2,,2]
HRRZ AR1,B
BLT B,177(AR1)
CHOQUT: MOVE AR1,C
JRST CHRQUT
INISET: PUSH P,A
MOVE A,B
JUMPE A,INFNLY
CAIN A,TRUTH(S)
MOVEI A,INUM0-1
PUSHJ P,NUMVAL
INFNLY: MOVE T,A
MOVEI TT,
POP P,B
PUSHJ P,TABSR1
JUMPN A,GTCN
TRO B,400000
PUSHJ P,TABSR1
JUMPE A,[ERR1 [SIXBIT /NON-EXISTENT CHANNEL -- USETX !/]]
GTCN: DPB A,[POINT 4,.USETI,12]
DPB A,[POINT 4,.USETO,12]
DPB A,[POINT 4,.UGETF,12]
DPB A,[POINT 4,.OUTPUT,12]
DPB A,[POINT 4,.INPUT,12]
DPB A,[POINT 4,.GETSTS,12]
MOVE A,CHREC(C)
TRNN B,400000
JRST RETC
HRRZ AR1,INCHAN(C)
JUMPN AR1,CPOPJ
RETC: MOVE AR1,C
POPJ P,
CALCHR: SKIPN B,COUNT(AR1)
MOVEI B,1
IMULI A,200*5
SUBI A,-2(B)
JUMPLE T,CPOPJ
ADDI T,<200*5>-1
IDIVI T,200*5
PUSH P,AR2A+1
MOVEI AR2A,4(TT)
IDIVI AR2A,5
HLL AR2A,[POINT 0,0,6
POINT 0,0,13
POINT 0,0,20
POINT 0,0,27
POINT 0,0,34](AR2A+1)
POP P,AR2A+1
SUBI TT,<200*5>+1
POPJ P,
REMOTE <
INPTST: CAME AR1,C
PUSHJ P,OPTST1
INPTS1:
.USETI: USETI X,(T)
MOVEI B,
.INPUT: IN X,
JRST [AOS COUNT(AR1)
POPJ P,]
.GETSTS:GETSTS X,B
TRNE B,740000
ERR1 [SIXBIT /INPUT ERROR -- USETI !/]
POPJ P,
OPTST2:
.USETO: USETO X,(T)
OPTST1:
.OUTPUT:OUT X,
SKIPA
ERR1 [SIXBIT /OUTPUT ERROR -- USETO !/]
AOS COUNT(C)
POPJ P,
>;!!!REMOTE
;IOSEL
REMOTE<
RLS: RELEASE X, ;release channel
>;!!!REMOTE
IOSEL: MOVE C,-1(P)
JUMPE C,CPOPJ ;tty
JUMPE B,IOSELZ ;dont release
DPB C,[POINT 4,RLS,ACFLD]
XCT RLS
; DCS 8-73 RANDOM -- Replaces HRRZS CHTAB(C) ... Release both
; input and output sides of old CHANNEL, if flag is T
PUSH P,A ;Now, if the file being released is
PUSH P,B
HRRZS A,CHTAB(C) ; an update file, CONS the input
MOVE B,CHNAM(A)
TRNN B,400000
JRST NOUPD
HRRZ A,INCHAN(A) ; buffer pointer onto the free
JUMPE A,NOUPD ; input-for-update buffer list
MOVE B,SAVIOB(S)
PUSHJ P,CONS
MOVEM A,SAVIOB(S)
NOUPD: POP P,B
POP P,A
MOVEM 0,@CHTAB(C) ;blast channel name
SETZM -1(P)
IOSELZ: HRRZ C,CHTAB(C)
POPJ P,
;INCNT, INC
INCNT: MOVEI A,NIL ;(INC NIL T)
MOVEI B,TRUTH(S)
INC: PUSH P,INCH#
TRZ A,400000 ;Some idiots use INUM's as channel names.
PUSHJ P,IOSEL
JUMPN B,INC2 ;released channel
SKIPN C
MOVEI C,TTOCH-CHOCH ;tty deselect
IFN STPGAP,<
MOVEI B,CHOCH(C)
HRLI B,OLDCH
BLT B,CHLINE(C) ;save channel data
>
IFE STPGAP,<
MOVE B,OLDCH
MOVEM B,CHOCH(C)
>
JRST INC2+1
INC2: SETZM INCH ;CLEAR CHANNEL NOW IN CASE OF BREAK
JUMPE A,ITTYRE ;select tty
MOVE B,A
PUSHJ P,TABSR1 ;determine physical channel number
; DCS 8-73 RANDOM -- if can't find as input file, maybe can find,
; disguised under output file, as INOUT file.
JUMPE A,[TRO B,400000 ;Didn't find it as input file, perhaps
PUSHJ P,TABSR1 ; it's an update file, in which case
JUMPE A,[ERR1 [SIXBIT/NO INPUT - INC!/]]
HRRZ C,INCHAN(C); the input pointer would be in INCHAN
JUMPE C,[ERR1 [SIXBIT/NO INPUT - INC!/]]
JRST DEPINC] ; of the output buffer representing chan.
DEPINC: HRRZM A,INCH
DPB A,[POINT 4,TYI2X,ACFLD] ;set up channel numbers
DPB A,[POINT 4,TYI2Y,ACFLD]
DPB A,[POINT 4,TYI2Z,ACFLD]
MOVEI T,COUNT(C)
HRLI T,(<SOSG>)
; DCS USERIO 9-73 -- interface to TYIFN code for each TYI -- from there
; control will transfer to user routine.
SKIPGE CHNAM(C) ;FN: DEVICE?
MOVE T,[JRST TYIFN+X]
MOVEI B,POINTR(C)
MOVEM B,TYI3 ;set up tyi parameters
HRRM B,TYI3A
INC3:
IFN STPGAP,<
MOVSI B,CHOCH(C)
HRRI B,OLDCH
BLT B,LINUM ;restore channel data
>;!!!STPGAP
IFE STPGAP,<
MOVE B,CHOCH(C)
MOVEM B,OLDCH
>;!!!UNSTPGAP
MOVEM T,TYI2
; DCS USERIO 9-73 -- if a USERIO channel, the transfer to IOFN will put the
; user routine name there. Otherwise, it will transfer garbage, but no-one
; will look there, so that's all right.
IOEND: MOVE C,FNNAME(C)
MOVEM C,IOFN#
POP P,A
JUMPE A,CPOPJ
MOVE A,CHTAB(A) ;get channel name
HRRZ A,CHNAM(A)
TRZ A,400000 ;clear output bit
POPJ P,
ITTYRE: SETZM INCH
MOVE T,[JRST TTYI] ;reselect tty
MOVEI C,TTOCH-CHOCH
JRST INC3
;OUTCNT, OUTC
OUTCNT: MOVEI A,0 ;(outc nil t)
MOVEI B,1
OUTC: PUSH P,OUTCH#
PUSHJ P,IOSEL
JUMPN B,OUTC2 ;closed this file
SKIPN C
MOVEI C,TTOLL-CHLL ;tty deselect
MOVE B,CHCT
MOVEM B,CHHP(C) ;save channel data
MOVE B,LINL
MOVEM B,CHLL(C)
JRST OUTC2+1
OUTC2: SETZM OUTCH ;CLEAR CHANNEL NOW IN CASE OF BREAK
JUMPE A,OTTYRE ;return to tty
TRO A,400000 ;set output bit
MOVE B,A
PUSHJ P,TABSR1 ;determine physical channel number
JUMPE A,[ERR1 [SIXBIT /NO OUTPUT - OUTC!/]]
DPB A,[POINT 4,TYO2X,ACFLD] ;set up tyo2 channel numbers
HRRZM A,OUTCH
MOVEI B,POINTR(C)
HRRM B,TYO5 ;set up tyo2 parameters
MOVEI T,COUNT(C)
HRLI T,(<SOSG>)
; DCS USERIO 9-73 -- interface to TYOFN for user TYO output.
SKIPGE CHNAM(C)
MOVE T,[JRST TYOFN+X]
OUTC3: MOVE B,CHLL(C)
MOVEM B,LINL
MOVE B,CHHP(C)
MOVEM B,CHCT
MOVEM T,.TYOD
JRST IOEND
OTTYRE: SETZM OUTCH
MOVE T,[JRST .TTYO]
MOVEI C,TTOLL-CHLL ;tty reselect
JRST OUTC3
AIN.1: PUSHJ P,AIOP
ERR1 [SIXBIT $ILLEGAL I/O ARG!$]
AOUT.2:
AIN.2: PUSHJ P,AIOP
ERR1 [SIXBIT /ILLEGAL DEVICE!/]
AOUT.4:
AIN.4: PUSHJ P,AIOP
ERR1 [SIXBIT /DEVICE NOT AVAILABLE !/]
AIN.7: PUSHJ P,AIOP
ERR1 [SIXBIT /CAN'T FIND FILE - INPUT!/]
AIN.8: SIXBIT /INPUT ERROR!/
AIOP: MOVE A,DEVDAT
JRST EPRINT
SUBTTL QMANGR INTERFACE
;## CODE TO ALLOW LISP USER'S TO CALL DEC'S QMANGR, ALLOWING
;## PRINTING OF FILES AND CREATION OF JOBS
;## SCANS ARG LIST SETTING UP THE APPROPRIATE PARAMETERS. IT
;## SAVE THE PDLS, SWAPS HI-SEGS FOR SYS:QMANGR AND
;## DOES A PUSHJ TO 400010. IT ALSO CHANGES JOBREN SO
;## THAT THE USER CAN RECOVER IN CASE OF QMANGR ERRORS.
;## ST WILL ALSO STILL WORK. REG 17 (SP) IS USED AS QMANGR'S
;## PDL. CORE IS CONTRACTED AFTER RETURN FROM QMANGR AND QUEUE
;## RESTORES APPROPRIATE REGS AND RETURNS NIL. ALTHOUGH
;## CODE FOR EXTENDED SWITCHES IS INCLUDED, MOST OF
;## IT IS TURNED OFF. USE AT YOUR OWN RISK. NOTE THAT
;## /LIST, /AFTER AND /DEAD REQUIRE SPECIAL CODE
;## THAT IS NOT INCLUDED. SEE APPROPRIATE
;## DEC DOCUMENTATION FOR FURTHER INFO. 6/12/73
IFN QALLOW <
IFNDEF QSWEXT <QSWEXT←0> ;## IF NOT DEFINED THEN DEFAULT IS NO EXTENDED
IFE QSWEXT <NSWS←←QTABL1>;## NUMBER OF ALLOWED SWITCHES
IFN QSWEXT <NSWS←←QTABL2>;## LENGTH OF EXTENDED TABLE
IFNDEF QLSTOK <QLSTOK←←0>
IFNDEF QTIME <QTIME←←0>
;%% THE FOLLOWING CODE IS AN ILLUSTRATION OF HOW
;%% EASY IT IS TO LOSE TRYING TO INTERFACE TO
;%% DEC SOFTWARE. THE FOLLOWING DEFINITIONS ALLOW
;%% TOO FEW WORDS FOR THE CURRENT FILE PARAMETER
;%% AREA; SEE THE DEFINITIONS AS COPIED FROM
;%% THE QMANGR SOURCE BELOW.
COMMENT &
INPPAR←←32 ;## NUMBER OF WORDS IN INP AREA FOR INPUT REQUEST
OUTPAR←←24 ;## NUMBER WORDS IN MAIN AREA FOR OUTPUT REQUEST
DIFPAR←←INPPAR-OUTPAR ;## DIFFERENCE IN LENGTHS FOR MAIN AREA TYPES
FILPAR←←14 ;## NUMBER WORDS IN FILE PARAMTER AREA
;## LOCATIONS IN PARAMETER AREAS
;## MAIN AREA
Q.MEM←←0 ;## MEMORY FOR QMANGR
Q.OPR←←1 ;## REQUESTED OPERATION
Q.LEN←←2 ;## RH←NUMBER OF FILES IN REQUEST
Q.DEV←←3 ;## REQUESTED QUEUE
Q.PPN←←4 ;## PPN REQUESTING
Q.JOB←←5 ;## JOB NAME
Q.SEQ←←6 ;## JOB SEQUENCE #
Q.PRI←←7 ;## EXTERNAL PRIORITY
Q.PDEV←←10 ;##
Q.TIME←←11 ;##
Q.CREA←←12 ;##
Q.AFTR←←13 ;## AFTER PARAMETER
Q.DEAD←←14 ;## DEADLINE PARAMETER
Q.CNO←←15
Q.USER←←16 ;## AND 17
;## INPUT SECTION OF MAIN PARAMETER AREA
Q.IDEP←←20 ;## RESTART AND DEPENDENCY PARAMTERS
Q.ILIM←←21 ;## CORE AND CPU, +1 IS LPT LIMIT AND CDP LIMIT
;## +2 IS PTP LIMIT AND PLOT LIMIT
Q.IDDI←←24 ;## THRU 31
Q.IEND←←31 ;## LAST LOC OF INP AREA
;## OUTPUT SEECTION OF MAIN PARAMETER AREA
Q.OFRM←←20 ;## FORM PARAMTER
Q.OSIZ←←21 ;## LH←LIMIT
Q.ONOT←←22
Q.OEND←←23 ;## LAST LOC OF OUTPUT AREA
;## FILE PARAMETER AREA (ONE FOR EACH FILE)
Q.FSTR←←0 ;## FILE STRUCTURE
Q.FDIR←←1 ;## THRU 6, DIRECTORY
Q.FNAM←←7 ;## FILE NAME
Q.FEXT←←10 ;## FILE EXTENSION
Q.FRNM←←11 ;## RENAME NAME (0)
Q.FBIT←←12
Q.FMOD←←13 ;## SPACING, FILE DISPOSAL, COPIES
& ;%% END OF DELETED DEFINITIONS
;%% THE FOLLOWING ARE AS COPIED FROM QMANGR (VERSION 34)
;%% ON 24 OCTOBER 1973
QDEFST←←. ;%% WHERE TO RELOC TO AFTERWARDS
RELOC 0 ;%% TO SAVE CORE AND AVOID CONFUSION
;%% COMMENTS BELOW ARE AS COPIED
;%% FROM QMANGR
PHASE 0
Q.ZER:! ;START OF QUEUE PARAMETER AREA
Q.MEM:! BLOCK 1 ;HOLD XWD WINDOW BLOCK,WINDOW WORD INDEX
Q.OPR:! BLOCK 1 ;OPERATION CODE
QO.CRE←←1 ;CREATION OPERATION
QO.LST←←4 ;LIST OPERATION
QO.MOD←←5 ;MODIFY OPERATION
QO.KIL←←6 ;KILL OPERATION
QO.DEL←←10 ;DELETE OPERATION
QO.REQ←←11 ;REQUEUE OPERATION
QO.FLS←←12 ;FAST LIST OPERATION
Q.LEN:! BLOCK 1 ;LENGTHS IN AREA
Q.DEV:! BLOCK 1 ;DESTINATION DEVICE
Q.PPN:! BLOCK 1 ;PPN ORIGINATING REQUEST
Q.JOB:! BLOCK 1 ;JOB NAME
Q.SEQ:! BLOCK 1 ;JOB SEQUENCE NUMBER
Q.PRI:! BLOCK 1 ;EXTERNAL PRIORITY
Q.PDEV:! BLOCK 1 ;PROCESSING DEVICE
Q.TIME:! BLOCK 1 ;PROCESSING TIME OF DAY
Q.CREA:! BLOCK 1 ;CREATION TIME
Q.AFTR:! BLOCK 1 ;AFTER PARAMETER
Q.DEAD:! BLOCK 1 ;DEADLINE TIMES
Q.CNO:! BLOCK 1 ;CHARGE NUMBER
Q.USER:! BLOCK 2 ;USER'S NAME
Q.I:! ;START OF INPUT QUEUE AREA
Q.IDEP:! BLOCK 1 ;DEPENDENCY WORD
Q.ILIM:! BLOCK 3 ;JOB LIMITS
Q.IL:! ;END OF AREA NEEDED TO READ FOR MASTER QUEUE
Q.IDDI:! BLOCK 6 ;JOB'S DIRECTORY
Q.II:! ;START OF INPUT FILES AREA
PHASE Q.I
Q.O:! ;START OF OUTPUT QUEUE AREA
Q.OFRM:! BLOCK 1 ;FORMS REQUEST
Q.OSIZ:! BLOCK 1 ;LIMIT WORD
Q.OL:! ;END OF AREA NEEDED TO READ FOR MASTER QUEUE
Q.ONOT:! BLOCK 2 ;ANNOTATION
Q.FF:!
PHASE 0
Q.F:! ;DUPLICATED AREA FOR EACH REQUESTED FILE
Q.FSTR:! BLOCK 1 ;FILE STRUCTURE
Q.FDIR:! BLOCK 6 ;ORIGINAL DIRECTORY
Q.FNAM:! BLOCK 1 ;ORIGINAL NAME
Q.FEXT:! BLOCK 1 ;ORIGINAL EXTENSION
Q.FRNM:! BLOCK 1 ;RENAMED FILE NAME (0 IF NOT)
Q.FBIT:! BLOCK 1 ;BIT 0←PRESERVED BY QUEUE, REST←STARTING BIT
Q.FMOD:! BLOCK 1 ;FILE SWITCHES
X.LOG←←1B1 ;FILE IS LOG FILE
X.NEW←←1B2 ;OK IF FILE DOESNT EXIST YET
Q.FRPT:!BLOCK 2 ;/REPORT
Q.FLEN←←.-Q.F
DEPHASE
PHASE 0
Q.FDRM:! BLOCK 6 ;DIRECTORY MASK FOR MODIFY
Q.FNMM:! BLOCK 1 ;FILE NAME MASK FOR MODIFY
Q.FEXM:! BLOCK 1 ;EXTENSION MASK FOR MODIFY
Q.FMDM:! BLOCK 1 ;MODIFIER MASK FOR MODIFY
Q.FMLN←←.-Q.F ;LENGTH OF MODIFY BLOCK
DEPHASE
RELOC QDEFST ;%% MAKE UP FOR INCREASE IN LOCATION
;%% COUNTER
INPPAR←←Q.II ;%% SIZE OF MINIMUM INPUT AREA
OUTPAR←←Q.FF ;%% SIZE OF MINIMUM OUTPUT AREA
OUTPR1←←OUTPAR-1 ;%% MACRO DOESN'T LIKE EXPRESSIONS
DIFPAR←←INPPAR-OUTPAR ;%% DIFFERENCE IN AREAS
FILPAR←←Q.FLEN ;%% FILE DATA AREA
LOWLEN←←=110 ;## AREA NEED FOR PARAMETER
;## AREA TO QMANGR
LHLEN←←OUTPR1*1B26+FILPAR ;## LH OF Q.LEN DEFAULTS
NQS←←6 ;## NUMBER OF QUEUES
;## QUEUE ERRORS
QILLSW: HLRZ A,(T) ;## GET SWITCH THAT CAUSED ERROR
PUSHJ P,PRINT
STRTIP [SIXBIT / ←ILL. SWITCH SPEC.!/]
PUSHJ P,CONCOR ;## SAVE THAT CORE
QERR1: ERR1 [SIXBIT /ERROR IN QUEUE REQUEST!/]
QUEUE: SKIPN T,A ;## ERROR IF NO ARGS
JRST QERR1
PUSHJ P,DEVCHK ;## SEE IF QUEUE SPECIFIED
JUMPE A,NOQUE ;## IF A←0 THEN NOT A QUEUE
JUMPE B,NOQUE ;## IF B←0 THEN NOT A QUEUE
MOVE AR2A,A
HLRZ B,A ;## GET FIRST THREEE LETTERS
MOVEI C,NQS ;## GET NUMBER OF PERMISSIBLE QUEUES
SOJL C,NOQUE ;## IF EXHAUSTED TABLE, THEN NO QUEUE
MOVE A,QSTABL(C) ;## PERMISSIBLE QUEUES
JSP R,CHKGO ;## JUMP TO ROUTINE THAT COMPARES RH AND GO
;## TO LH OF A IFF RH(A)←B
JRST .-3 ;## LOOP
;## TABLE OF PERMISSIBLE QUEUES AND WHERE TO GO ON EACH
QSTABL: XWD INPREQ, 'INP'
XWD OUTREQ, 'LPT'
XWD OUTREQ, 'PTP'
XWD OUTREQ, 'PTP'
XWD OUTREQ, 'CDP'
XWD OUTREQ, 'PLT'
OUTREQ: TDZA A,A ;## HERE TO PROCESS OUTPUT REQUEST(CLEAR A)
INPREQ: MOVEI A,DIFPAR ;## HERE TO PROCESS INPUT REQUEST
JRST QGOOD ;## FOUND A QUEUE
NOQUE: MOVSI AR2A,'LPT' ;## HERE IF NO QUEUE, DEFAULT←LPT
TDZA A,A ;## CLEAR A AND SKIP
QGOOD: HRRZ T,(T) ;## HERE IF QUEUE SPECIFIED
ADDI A,OUTPAR ;## A IS ZERO OR INPPAR
QSETUP: PUSH P,B ;## B CONTAINS THREE LETTERS(OR BLANK). SAVE IT
HRLZI TT,(A) ;## SAVE LNENGTH OF AREA
PUSHJ P,TEMCOR ;## EXPAND CORE
HRRI TT,(A) ;## START ADDR OF MAIN AREA
MOVE A,TT
PUSHJ P,CLRBLK ;## CLEAR AREA
MOVEM AR2A,Q.DEV(TT)
MOVEI C,LHLEN ;## GET LENGTHS FOR HEADER AND FILE AREAS
MOVE A,[XWD 500,500]
HRLZM A,Q.OSIZ(TT) ;## ASSUME OUTPUT HERE
POP P,B ;## RESTORE LEFT THREE LETTERS
CAIE B,'INP' ;## WAS IT AN INPUT REQUEST?
JRST QUEUE1 ;## NO SHOULD BE OK
ADDI C,DIFPAR←9 ;## UPDATE HEADER LENGTH
MOVEM A,Q.ILIM+1(TT) ;## MAX PAGES AND CARD PUNCH
MOVEM A,Q.ILIM+2(TT) ;## MAX PAPER TAPE AND PLOTTER
HRLI A,=256
MOVEM A,Q.ILIM(TT) ;## MAX CORE AND CPU(CORMAX MAY HAVE TO BE
;## CHECKED HERE)
MOVSI A,400000 ;## SET BIT 0 FOR NOT RESTARTABLE
HLLZM A,Q.IDEP(TT) ;## NOT RESTARTABLE(NO DEPEND OR UNIQUENESS)
QUEUE1: MOVSM C,Q.LEN(TT) ;## SET HEADER AND FILE AREA LENGTHS
GETPPN A, ;## SET REQUESTING PPN
CAI ;## WEIRD SKIP RETURN ON THIS UUO
MOVEM A,Q.PPN(TT)
SETZ REL, ;## CLEAR REG FOR FILE AREA
MOVEI A,20 ;## PRIORITY DEFAULT
MOVEM A,Q.PRI(TT)
AOSA Q.OPR(TT) ;## SET DEFAULT FOR REQUEST TYPE←/CREATE
;## BASIC LOOP FOR HANDLING THE SWITCHES
QLOOP: HRRZ T,(T) ;## HERE IF ROUTINE DID NOT MOVE ARG
QSELF: JUMPE T,QDONE
PUSHJ P,DEVCHK ;## SEE IF DEVICE OR ATOMIC FILE NAME?
JUMPN B,QFILEA ;## IF B#0 THEN DEVICE
JUMPN A,QFILE ;## IF A#0 THEN ATOMIC FILE
HLRZ C,(T) ;## WELL, SEE IF SWITCH
HRRZ A,(C) ;## CDAR
PUSHJ P,ATOM ;## ATOM?
JUMPN A,QFILE ;## YES, THEREFORE(FILE.EXT)
HLRZ B,(C) ;## CAAR
SUBI B,(S) ;## STRIP OFF RELOCATION
HRRZI C,NSWS ;## GET NUMBER OF SWITCHES
QLOOP1: SOJL C,QFILE ;## IF NO SWITCH, GO QFILE
MOVE A,QTABLE(C) ;## GET MEMBER OF TABLE
JSP R,CHKGO
JRST .-3 ;## LOOP
;## DISPATCH TABLE FOR SWITCHES
QTABLE:
PHASE 1
XWD QCOPIE,COPIES ;## /COPIES
XWD QCPU,CPU ;## /CPU
XWD QFORMS,FORMS ;## /FORMS
XWD QLIMIT,LIMIT ;## /LIMIT
QTABL1: XWD QDISP,DISP ;## /DISP (FILE DISPOSITION)
;## EXTENDED SWITCHES
IFN QSWEXT <
IFE QLSTOK <XWD QILLSW, LISTAT>
IFN QLSTOK <XWD QLIST, LISTAT>
IFE QTIME <
XWD QILLSW,AFTER ;## /AFTER ILLEGAL (SEE ABOVE)
XWD QILLSW,DEAD ;## /DEAD (DEADLINE)
>
IFN QTIME <
XWD QAFTR,AFTER
XWD QDEAD,DEAD
>
XWD QCORE,COREAT
XWD QMOD,MODIFY ;## /MODIFY
XWD QKILL,KILL ;## /KILL
XWD QJOB,JOB ;## /JOB
XWD QDEPND,DEPEND ;## /DEPEND
XWD QRSTR,RSTRT ;## /RESTART
XWD QUNIQ,UNIQUE ;## /UNIQUE
XWD QCORE,COREAT ;## /COREE
XWD QPAGES,PAGES ;## /PAGES
XWD QPLOT,PLOT ;## /PLOT
XWD QPTAPE,PTAPE ;## /PTAPE
XWD QCARDS,CARDS ;## /CARDS
XWD QSEQ,SEQ ;## /SEQ
XWD QPRIOR,PRIOR ;## /PRIOR (PRIORITY)
XWD QSPACE,SPACE ;## /SPACE (SPACING)
XWD QLIMIT,LIMIT ;## /LIMIT
QTABL2: XWD QHEAD,HEAD ;## /HEAD (HEADERS)
>
DEPHASE
;## DISPATCHING THE VARIOUS SWITCHES
IFN QSWEXT <QLIST: HRRZI A,4 ;## HERE FOR LIST REQUEST
CAIA
QMOD: HRRZI A, 5 ;## /MODIFY
CAIA
QKILL: HRRZI A, 6 ;## /KILL
HRRZM A, Q.OPR(TT)
JRST QLOOP
>
;## INPUT QUEUE ONLY SWITCHES
;## PUTS BYTE POINTER INTO B AND THEN CHECKS TO SEE IF SWITCH VALID IN
;## THIS CONTEXT (I.E. ARE WE PROCESSING AN INPUT REQUEST?)
;## IF NOT VALID, SKIPS THE SWITCH(MAY BE CHANGED LATER)
IFN QSWEXT <
QPLOT: JSP R,RINPCH
AOJA B, QCARD+1
QPTAPE: JSP R, LINPCH
AOJA B, .+4
QCARDS: JSP R, RINPCH
AOJA B, .+4
QPAGES: JSP R, LINPCH
AOJA B, .+4
>
QCPU: JSP R, RINPCH
AOJA B,QARG
IFN QSWEXT <
QCORE: JSP R, LINPCH
AOJA B,QARG
QDEPND: JSP R, RINPCH
JRST QARG
>
;## OUTPUT QUEUE ONLY SWITCHES
QFORMS: JSP R, OUTCHK
PUSH P,QSXARG ;## CONVERT ARG TO SIXBIT
MOVEM A, Q.OFRM(TT) ;## MAKE SIXBIT IF FORMS
JRST QLOOP
QLIMIT: JSP R, OUTCHK
MOVE B,LINP
AOJA B,QARG
OUTCHK: HLRZ A,Q.DEV(TT) ;## GET REQUEST TYPE (THREE LETTERS)
CAIE A,'INP' ;## ERROR IF INPUT REQUEST
JRST (R)
JRST QILLSW
QCOPIE: JSP R, FILECH ;## CHECK IF WE HAVE SET UP A FILE AREA
MOVE B,[POINT 6,Q.FMOD(REL),35] ;## BYTE POINTER
JRST QARG
;## FOR DISPOSITION, 1←PRESERVE, 2←RENAME, 3←DELETE,
;## FIRST THREE LETTERS OF ARG TO SWITCH UNIQUELY IDENTIFY
;## ILLEGAL ARG CAUSES ERROR
QDISP: JSP R,FILECH ;## BE SURE FILE AREA SET UP
PUSHJ P,QSXARG ;## MAKE ARG SIXBIT
HLRZ C,A ;## GET FIRST THREE LETTERS
SETZ A, ;## CLEAR A
CAIN C,'DEL' ;## DELETE AFTER OUTPUT!
AOJA A,.+2 ;## YES!
CAIN C,'REN' ;## RENAME FILE OUT OF UFD?
AOJA A,.+3
CAIE C,'PRE' ;## PRESERVE IT
JRST QILLSW ;## HERE IF BAD ARGUMENT
ADDI A,1
MOVE B, [POINT 3, Q.FMOD(REL), 29]
JRST QARG+1 ;## ARG ALREADY IN A
;## HERE WHEN SWITCH DETERMINED AND BITE POINTER IN B
QGTARG: MOVEI A,(T)
PUSHJ P,CADAR
SUBI A,INUM0 ;## ARG SHOULD BE AN INUM
POPJ P,
QARG: PUSHJ P,QGTARG ;## GET ARGUMENT
DPB A,B ;##
JRST QLOOP ;## ALWAYS RETURN TO QLOOP
;## HERE TO SEE IF INP QUEUE FOR EXTENDED PART OF MAIN AREA
LINPCH: MOVE B,LINP ;## GET LH BITE POINTER
CAIA
RINPCH: MOVE B,RINP ;## GET RH BITE POINTER
HLRZ A,Q.DEV(TT) ;## GET QUEUE SPEC
CAIN A,'INP' ;## INP?
JRST (R) ;## YES
JRST QILLSW
LINP: POINT 18, Q.IDEP(TT),17 ;## BYTE POINTER FOR LEFT HALF OF EXTENDED MAIN AREA
RINP: POINT 18, Q.IDEP(TT),35 ;## BYTE POINT FOR RH OF EXTENDED MAIN AREA
;## HERE TO BE SURE FILE AREA HAS BEEN SET UP
FILECH: JUMPN REL,(R) ;## REL NONZERO IF FILE AREA SET UP
PUSH P,R
JRST FILARE
;## HERE TO FIND FILE SPECIFICATION
QFILEA: HRRZ T,(T) ;## GET CDR
SETZ B, ;## CLEAR B
JRST QFILEB
QFILE: MOVSI A,'DSK' ;## DEFAULT IS DSK
CAIE REL,0 ;## AREA SET UP?
SKIPA A,Q.FSTR(REL) ;## GET CURRENT DEVICE
SKIPA B,Q.PPN(TT) ;## GET USER'S PPN IF NOT SET UP
MOVE B,Q.FDIR(REL) ;## GET CURRENT PPN
QFILEB: MOVEM B,PPN ;## SET PPN
MOVEM A,DEV ;## HANG ON TO DEVICE
JUMPE T,QSELF ;## IF NIL THEN DONE
PUSHJ P,NXTIO ;## FAKE IOSUB SEQUENCE
PUSHJ P,IOPPN
PUSH P,A ;## IOPPN RETURNS FILE NAME IN A
CAIE REL,0 ;## AREA SET UP?
SKIPE Q.FNAM(REL) ;## AREA SET UP, BUT NO FILE NAME?(PRECEDING SWITCHES)
PUSHJ P,FILARE ;## SET UP AREA
MOVE A,DEV ;## GET DEVICEE
MOVEM A,Q.FSTR(REL) ;## SET FILE STRUCTURE
MOVE A,EXT ;## GET EXTENSION
MOVEM A,Q.FEXT(REL) ;## SET IT
MOVE A,PPN ;## GET PPN
MOVEM A,Q.FDIR(REL)
;## SET IT(DIRECTORY)
POP P,Q.FNAM(REL) ;## RESTORE NAME
JRST QSELF ;## T HAS BEEN RESET BY IO ROUTINES!
;## HERE TO SET UP FILE AREA
FILARE: AOS Q.LEN(TT) ;## ADD ONE TO NUMBER FILES IN REQUEST
HRLZI A,FILPAR
ADD TT,A ;## ADD TO LENGTH OF PARAMETER AREA
HRRZI A,FILPAR
PUSHJ P,EXPCOR
JUMPE REL,FILDEF ;## SET DEFAULST IF NO PREVIOUS FILE AREA
HRL A,REL
HRRZI B,(A) ;## SET UP FOR BLT OF PREVIOUS AREA
ADDI B,FILPAR-1 ;## FINAL DESTINATION ADDRESS
HRRZI REL,(A) ;## NEW FILE AREA
BLT A,(B)
SETZM Q.FNAM(REL)
POPJ P,
FILDEF: HRRZI REL,(A)
HRLI A,FILPAR
PUSHJ P,CLRBLK
HRLZI A,'DSK'
MOVEM A,Q.FSTR(REL)
MOVE A,[EXP 1B5+1B20+1B26+1B29+1] ;## DEFAULTS FOR Q.FMOD
MOVEM A,Q.FMOD(REL)
POPJ P,
;## HERE WHEN FINISHED
QDONE: MOVE AR1,OUTPAR+Q.FNAM(TT) ;## GET FIRST FILE NAME
HLRZ A,Q.DEV(TT) ;## GET FIRST THREE LETTERS OF Q AGAIN
CAIE A,'INP' ;## INPUT QUEUE?
JRST QDONEB ;## NO
MOVE AR1,INPPAR+Q.FNAM(TT) ;## GET CORRCT FILE NAME
HRRZ A,Q.LEN(TT) ;## GET NUMBER OF FILES SPECIFIED
SOJG A,QDONEC ;## GREATER THAN ONE MEANS THAT USER
;## SPECIFIED A LOG FILE
PUSHJ P,FILARE ;## WE HAVE TO SET UP LOG FILE
HRRZI A,'LOG' ;## CHANGE EXTENSION TO .LOG
HRLZM A,Q.FEXT(REL)
MOVEM AR1,Q.FNAM(REL) ;## SET TO INP FILE NAME
QDONEC: HRRI A,3
DPB A,[POINT 2,INPPAR+FILPAR+Q.FMOD(TT),2];## SET BITS
;## INDICATING LOG FILE AND DOESN'T EXIST
;## (AVOIDS ERROR MSGS FROM QMANGR)
;## IN SECOND FILE IN CASE USER STUPIDLY SET
;## UP MORE THAN TWO
QDONEB: SKIPE Q.JOB(TT) ;## SPECIFIED NAME
JRST QDONE1 ;## YES, DONE
MOVEM AR1,Q.JOB(TT)
QDONE1: MOVE C,[EXP 'QMANGR'];## SEGMENT NAME
MOVEI B,400010
MOVE A,TT
PUSHJ P,NEWHI
PUSHJ P,CONCOR ;## CONTRACT CORE
JRST FALSE ;## RETURN NIL
;## ROUTINE TO SWAP HI-SEGMENTS. REGISTER A CONTAINS ARG TO NEXT HI-SEG, B CONTAINS
;## LOCATION TO JUMP TO IN NEW HI-SEG. REGS ARE ARG BLOCK TO GETSEG UUO
;## TO THE GET SEG
NEWHI: PUSH P,SP ;## HAVE TO SAVE SP, SINCE MOST
;## SYSTEM PROGS USE 17 FOR THEIR PDL
MOVEM A,HIARGS# ;## SAVE ARG TO HI-SEG
HRRZM B,HIADDR# ;## SAVE ADDR TO HI-SEG
PUSH P,JOBFF ;%% SAVE OLD VALUE
;%% (DON'T ASK WHY)
HLRZ B,A ;%% CALCULATE NEW VALUE
ADDI B,1(A) ;%%
MOVEM B,JOBFF ;%% RESET SO QMANGR WON'T WRITE
;%% OVER ARGUMENT BLOCK.
;%% JUST BECAUSE LISP IGNORES JOBFF
;%% DOESN'T MEAN ANYONE ELSE DOES
MOVEM P,PSAVE# ;## SAVE P (CAN'T USE SP)
MOVE SP,P ;## USE RPDL
HRRZI A,OLDHI ;## REE WILL RESTORE AND CONTINUE
MOVEM A,JOBREN
MOVEM A,JOBREN ;## SET FAKE REE ADDRESS
HRLZI B,'SYS' ;## SYS: IS LOCATION OF NEW HI-SEG
MOVEI A,B ;## B IS STARTING LOCATION OF BLOCK TO GETSEG
SETZB AR1,AR2A ;## CLEAR REST OF BLOCK
SETZB T,TT ;## DITTO
MOVEM SP,SAVSP# ;## SAVE SP AROUND GETSEG (WHICH CLOBBERS ACS)
JRST NEWHI1 ;## GO DO IT
;## HERE TO GET THAT HI-SEG
REMOTE <
NEWHI1: CALLI A,GETSEG
JRST @JOBREN ;## FAILED JOBREN HAS LOC OF RESTORE LISP HI-SEG
MOVE SP,SAVSP
MOVE A,HIARGS
PUSHJ SP,@HIADDR ;## JUMP TO HI-SEG
OLDHI: MOVEI A,HGHDAT
CALLI A,GETSEG
HALT ;## YOU'RE DEAD IF YOU ARE HERE
ENDHI: JRST RESTOR ;## JUMP TO RESTORE THINGS
>
RESTOR: MOVE P,PSAVE
POP P,JOBFF ;%% RESTORE OLD VALUE
POP P,SP
MOVE 0,STNIL
MOVE S,ATMOV
HRRZI A,DEBUGO
MOVEM A,JOBREN
POPJ P,
TEMCOR: HRRZ B,CORUSE ;## GET CURRENT CORUSE. THIS ROUTINE EXPANDS CORE
;## BUT SAVE INFO SO THAT IT CAN BE CONTRACTED LATER
HRL B,JOBREL ;## GET CURRENT CORE EXTENT
MOVEM B,OLDCU ;## SAVE IT (SEE LOADER INTERFACE)
EXPCOR: SETZ D, ;## D IS A RELOC REG
JRST MORCOR ;## EXPAND CORE
CONCOR: MOVS B,OLDCU ;## CONTRACTS CORE, OPPOSITE TEMCOR
HLRZM B,CORUSE
HRRZI B,(B) ;## CLEAR LH
PUSHJ P,MOVDWN ;## MOVE SYMBOL TABLE
HRRZM B,LSTCOR
CALLI B,CORE ;## CONTRACT (B SHOULD BE UNCHANGED
CAI
POPJ P, ;## DONE
QSXARG: MOVEI A,(T)
PUSHJ P,CADAR ;## GET ARGUMENT TO SWITCH
JRST SIXMAK ;## CONVERT IT TO SIXBIT
CLRBLK: SETZM (A) ;## CLEAR FIRST WORD
HLRZ B,A ;## LH OF A CONTAINS LENGTH
ADD B,A
HRL A,A
AOJ A, ;## RH NOW CONTAINS SOURCE+1
BLT A,-1(B) ;## BLT CLEARS BLOCK
POPJ P,
;## PICKUP
CHKGO: CAIN B,(A) ;## SEE IF RH(A)←(B)
HLRZ R,A ;## WHERE TO GO
JRST (R) ;## NO, RETURN
>
PAGE
SUBTTL PRINT
EPRINT: SKIPN ERRSW
POPJ P,
PUSHJ P,ERRIO
PUSHJ P,PRINT
JRST OUTRET
PRINT: MOVEI R,.TYO
PUSHJ P,.TERPRI
PUSHJ P,.PRIN1
XCT " ",CTY
JRST FORCE
; REAL WORK DONE BY .ROUT ROUTINES, WHICH DO NOT FORCE TTY OUTPUT.
; THESE ARE CALLED DIRECTLY BY USER, FORCE PRINTOUT ON COMPLETION.
PRINC: PUSHJ P,.PRINC ;Print one S-expr, slashified.
JRST FORCE
PRIN1: PUSHJ P,.PRIN1 ;Print one S-expr, unslashified.
JRST FORCE
TYO: PUSHJ P,.TYO ;Print one character, right now.
JRST FORCE
TTYO: PUSHJ P,.TTYO ;Type one character, right now.
JRST FORCE
TYOD: PUSHJ P,.TYOD
JRST FORCE
TERPRI: PUSHJ P,.TERPRI
JRST FORCE
.PRINC: SKIPA R,.+1
.PRIN1: HRRZI R,.TYO
PUSH P,A
PUSHJ P,PRINTA
JRST POPAJ
TPRIN1: MOVEI R,TTYO ;Do PRIN1 type output on the TTY. DOESN'T RETURN ARG !!
PRINTA: PUSH P,A
MOVEI B,PRIN3
SKIPGE R
MOVEI B,PRIN4
HRRM B,PRIN5
PUSHJ P,PATOM
JUMPN A,PRINT1
XCT "(",CTY
PRINT3: HLRZ A,@(P)
PUSHJ P,PRINTA
HRRZ A,@(P)
JUMPE A,PRINT2
MOVEM A,(P)
XCT " ",CTY
PUSHJ P,PATOM
JUMPE A,PRINT3
XCT ".",CTY
XCT " ",CTY
PUSHJ P,PRIN1A
PRINT2: XCT ")",CTY
JRST POPAJ
PRINT1: PUSHJ P,PRIN1A
JRST POPAJ
PRIN1A: MOVE A,-1(P)
CAILE A,INUMIN
JRST PRINIC
JUMPE A,PRIN1B
CAIGE A,@FSTOP
CAIGE A,@FSBOT
JRST PRINL
PRIN1B: HRRZ A,(A)
JUMPE A,PRINL
HLRZ B,(A)
HRRZ A,(A)
CAIN B,PNAME(S)
JRST PRINN
CAIN B,FIXNUM(S)
JRST PRINI1
CAIN B,FLONUM(S)
JRST 2,@[XWD 0,PRINO] ; TURN OFF DIVIDE CHECK AND UNDERFLOW
BPR: JRST PRIN1B ;bignums change here to JRST BPRINT
JRST PRIN1B
PRINL2: MOVEI R,TYO
JRST PRINL1
PRINL: XCT "#",CTY
HRRZ A,-1(P)
PRINL1: MOVEI C,8
JRST PRINI3
PRINI1: SKIPA A,(A)
PRINIC: SUBI A,INUM0
HRRZ C,VBASE(S)
SUBI C,INUM0
CAIN C,TEN ;Should number be followed by a `.' ?
SKIPE %NOPOINT(S)
JRST PRNTINT ;No.
MOVEI B,"."-"0"
HRLM B,(P)
PUSH P,PRINI4
PRNTINT:JUMPGE A,PRINI3
XCT "-",CTY
MOVNS A
PRINI3: JUMPL A,[ MOVEI B,0 ;case of -2↑35
MOVEI A,1
DIVI A,(C)
JRST .+2]
IDIVI A,0(C) ;Yet another instantiation of the oldest known
HRLM B,(P) ; coding trick for the PDP-6, namely, the infamous
SKIPE A ; recursive number printer. Old hacks never die...
PUSHJ P,.-3
PRINI4: JRST FP7A1
PRINN: HLRZ A,(A)
MOVEI C,2(SP)
PUSHJ P,PNAMU3
PUSH C,[0]
HRLI C,(<POINT 7,0,35>)
HRRI C,2(SP)
ILDB A,C
JUMPE A,CPOPJ ;special case of null character
CAIN A,DBLQT
JRST PSTR ;string
PRIN2X: LDB B,[POINT 1,CHRTAB(A),1]
JUMPL R,PRIN4 ;never slash
JRST PRIN2(B) ;1 for no slash
PRIN3: SKIPL CHRTAB(A) ;<0 for no slash
PRIN2: XCT "/",CTY
PRIN4: PUSHJ P,(R)
ILDB A,C
JUMPN A,@PRIN5#
POPJ P,
PSTR: MOVS B,(C)
CAIN B,(<ASCII /"/>)
JRST PRIN2X ;special case of /"
PSTR3: SKIPL R ;dont print " if no slashify
PSTR2: PUSHJ P,(R)
ILDB A,C
CAIE A,DBLQT
JUMPN A,PSTR2
JUMPN A,PSTR3
POPJ P,
.TERPRI:PUSH P,A
MOVEI A,CR
PUSHJ P,TYO
MOVEI A,LF
PUSHJ P,TYO
JRST POPAJ
CTY: JSA A,TYOI
REMOTE<
TYOI: X
JRST TYOI2>
TYOI2: PUSH P,A
LDB A,[POINT 6,-1(A),ACFLD]
PUSHJ P,(R)
POP P,A
JRA A,(A)
PRINO: MOVE A,(A)
CLEARB B,C
JUMPG A,FP1
JUMPE A,FP3
MOVNS A
XCT "-",CTY
FP1: CAMGE A,FT01
JRST FP4
CAML A,FT8
AOJA B,FP4
FP3: MULI A,400
ASHC B,-243(A)
MOVE A,B
CLEARM FPTEM#
PUSHJ P,FP7
XCT ".",CTY
MOVNI T,8
ADD T,FPTEM
MOVE B,C
FP3A: MOVE A,B
MULI A,TEN
PUSHJ P,FP7B
SKIPE B
AOJL T,FP3A
POPJ P,
FP4: MOVNI C,6
MOVEI TT,0
FP4A: ADDI TT,1(TT)
XCT FCP(B)
TRZA TT,1
FMPR A,@FCP+1(B)
AOJN C,FP4A
PUSH P,TT
MOVNI B,-2(B)
DPB B,[POINT 2,FP4C,34]
PUSHJ P,FP3
MOVEI A,"E"
PUSHJ P,(R)
MOVE A,FP4C#
IORI A,51
PUSHJ P,(R)
POP P,A
FP7: JUMPE A,FP7A1
IDIVI A,TEN
AOS FPTEM
HRLM B,(P)
JUMPE A,FP7A1
PUSHJ P,FP7
FP7A1: HLRE A,(P)
FP7B: ADDI A,"0"
JRST (R)
353473426555 ;1e32
266434157116 ;1e16
FT8: 1.0E8
1.0E4
1.0E2
1.0E1
FT: 1.0E0
026637304365 ;1e-32
113715126246 ;1e-16
146527461671 ;1e-8
163643334273 ;1e-4
172507534122 ;1e-2
FT01: 175631463146 ;1e-1
FT0:
FCP: CAMLE A,FT0(C)
CAMGE A,FT(C)
XWD C,FT0
PAGE
SUBTTL SUPER FAST TABLE DRIVEN READ 14-MAY-69
;magic scanner table bit definitions
;bit 0←0 iff slashified as nth id character
;bit 1←0 iff slashified as 1st id character
;bits 2-5 ratab index
;bits 6-8 dotab index
;bits 9-10 strtab index
;bits 11-13 idtab index
;bits 14-16 exptab index
;bits 17-19 rdtab index
;bits 20-25 ascii to radix 50 conversion
REMOTE<
IGSTRT: IGCRLF
IGEND: LF
RATFLD: POINT 4,CHRTAB(A),5
STRFLD: POINT 2,CHRTAB(A),10
IDFLD: POINT 3,CHRTAB(A),13
>
DOTFLD:
NUMFLD: POINT 3,CHRTAB(A),8
EXPFLD: POINT 3,CHRTAB(A),16
RDFLD: POINT 3,CHRTAB(A),19
R50FLD: POINT 6,CHRTAB(A),25
;magic state flags in t
EXP←←1 ;exponent
NEXP←←2 ;negative exponent
SAWDOT←←4 ;saw a dot (.)
MINSGN←←10 ;negative number
IDCLS←←0 ;identifier
STRCLS←←1 ;string
NUMCLS←←2 ;number
DELCLS←←3 ;delimiter
PAGE
;macros for scanner table
DEFINE RAD50 (X)<
IFIDN <X>< >,<R50VAL←0>
IFLE <"X"-"9">,<IFGE <"X"-"0">,<R50VAL←"X"-"0"+1>>
IFIDN <"X"><".">,<R50VAL←45>
IFIDN <"X"><"$">,<R50VAL←46>
IFIDN <"X"><"*">,<R50VAL←46>
IFIDN <"X"><"%">,<R50VAL←47>
IFGE <"X"-"A">,<R50VAL←"X"-"A"+13>>
DEFINE TABIN (S1,SN,R,D,S,I,E,RD,R50)<
;XLIST
FOR Xε{R50}{RAD50(X)↔BYTE (1)S1,SN(4)R(3)D(2)S(3)I,E,RD(6)R50VAL
};LIST
>
DEFINE LET (X)<
TABIN (1,1,5,2,3,4,2,0,<X>)>
DEFINE DELIMIT (X,Y)<
TABIN (0,0,2,2,3,2,2,Y,X)>
DEFINE IGNORE (X)<
TABIN (0,0,3,2,3,2,2,0,X)>
REMOTE<
CHRTAB:
TABIN (0,0,1,1,1,1,1,0,< >)
;null
LET (< >)
IGNORE (< >)
;tab,lf,vtab,ff,cr
LET (< >)
;16 to 30
TABIN (0,0,0,0,0,0,0,0,< >)
;igmrk
TABIN (0,0,0,0,0,0,0,0,< >)
;32 THE OLD IGMRK, WILL ALLOW THE CHAR. TO WORK ON READS BUT NOT TYI
;Shit. ≠ is a letter.;;DELIMIT (< >,3);## NEW ALTMODE (5S06 MONITOR)
LET (< >) ;≠
LET (< >)
;## 34 TO 37
IGNORE (< >)
;space
LET (< >)
;!
TABIN (0,0,9,2,2,2,2,0,< >)
;"
LET (< $% >)
;#$%&'
DELIMIT (< >,0)
DELIMIT (< >,1)
;()
LET (< >)
;*
TABIN (1,1,14,2,3,4,2,0,< >)
;+
IGNORE (< >)
;,
TABIN (1,1,6,2,3,4,2,0,< >)
;-
TABIN (0,0,7,3,3,2,2,4,<.>)
TABIN (0,0,4,2,3,3,2,0,< >)
;/
TABIN (1,0,8,5,3,4,3,0,<0123456789>)
LET (< >)
;:;<←>?
TABIN (1,0,2,2,3,4,2,5,< >)
;@
LET (<ABCD>)
TABIN (1,1,5,4,3,4,2,0,<E>)
LET (<FGHIJKLMNOPQRSTUVWXYZ>)
DELIMIT (< >,2)
;[
LET (< >)
;\
DELIMIT (< >,3)
;]
LET (< >)
;↑←`
LET (<ABCDEFGHIJKLMNOPQRSTUVWXYZ>)
;lower case
LET (< >)
;{¬
DELIMIT (< >,3)
;## OLD ALTMODE (5S04 MONITOR)
LET (< >)
;}
DELIMIT (< >,6)
;rubout
>;END REMOTE
READCH: PUSHJ P,TYI
MOVSI AR1,AR1
PUSHJ P,EXPL1
JRST CAR
READ0N: SOSA NOINFG
READP1: SETZM NOINFG
READ0: PUSH P,TYI2
PUSH P,OLDCH
SETZM OLDCH#
HRLI A,(<JRST>)
MOVEM A,TYI2
PUSHJ P,READX
POP P,OLDCH
POP P,TYI2
POPJ P,
RDNAM: SETOM NOINFG ;## READ ROUTINE THAT DOES NOT INTERN
JRST READX ;##
RDRUB: MOVEI A,CR
PUSHJ P,TTYO
MOVEI A,LF
PUSHJ P,TTYO
SKIPA P,PSAV#
READ: SETZM NOINFG# ;0 means intern
READX: MOVEM P,PSAV
PUSHJ P,READ1
SETZM PSAV
POPJ P,
READ1: PUSHJ P,RATOM
POPJ P, ;atom
XCT RDTAB2(B)
JRST READ1 ;try again
RDTAB2: JRST READ2 ;0 (
JFCL ;1 )
JRST READ4 ;2 [
JFCL ;3 ],$
JFCL ;4 .
JRST RDQT ;5 @
READ2: PUSHJ P,RATOM
JRST READ2A ;atom
XCT RDTAB(B)
READ2A: PUSH P,A
PUSHJ P,READ2
POPBXC: POP P,B
JRST XCONS
RDTAB: PUSHJ P,READ2 ;0 (
JRST FALSE ;1 )
PUSHJ P,READ4 ;2 [
JRST READ5 ;3 ],$
JRST RDT ;4 .
PUSHJ P,RDQT ;5 @
RDTX: PUSHJ P,RATOM
POPJ P, ;atom
XCT RDTAB2(B)
JRST DOTERR ;dot context error
RDT: PUSHJ P,RDTX
PUSH P,A
PUSHJ P,RATOM
JRST DOTERR
CAIN B,1
JRST POPAJ
CAIE B,3
JRST DOTERR
MOVEM A,OLDCH
JRST POPAJ
READ4: PUSHJ P,READ2
MOVE B,OLDCH
CAIE B,ALTMOD
TYI1: SETZM OLDCH ;kill the ]
POPJ P,
READ5: MOVEM A,OLDCH ;save ] or $
JRST FALSE ;and return nil
RDQT: PUSHJ P,READ1
JRST QTIFY
PAGE
;atom parser
COMMENT:PUSHJ P,TYID
CAME A,IGEND
JRST COMMENT
POPJ P,
RATOM: SKIPE SMAC# ;$$ CHECK FOR A SPLICE MACRO LIST
JRST PSMAC ;$$ GET ITEM FROM SPLICE MACRO LIST
SETZB T,R
HRLI C,(<POINT 7,0,35>)
HRRI C,(SP)
MOVEM C,ORGSTK# ;SAVE FOR BACKING UP ON + AND -
MOVEI AR1,1
RATOM2: PUSHJ P,TYIA
LDB B,RATFLD
JRST RATAB(B)
RATAB: PUSHJ P,COMMENT ;0 comment
JRST RATOM2 ;1 null
JRST RATOM3 ;2 delimit
JRST RATOM2 ;3 ignore
PUSHJ P,TYI ;4 /
JRST RDID ;5 letter
JRST RDNMIN ;6 -
JRST RDOT ;7 .
JRST RDNUM ;8 digit
JRST RDSTR ;9 string
JRST RMACRO ;10 MACRO
JRST SMACRO ;11 SPLICE MACRO
JRST RDNPLS ;12 +
;a real dotted pair
RDOT2: MOVEM A,OLDCH
MOVE A,ORGSGN ;ORGSGN NORMALLY CONTAINS A "." AT THIS POINT
RATOM3: LDB B,RDFLD
HRRI R,DELCLS ;delimiter
AOS (P) ;non-atom (ie a delimiter)
POPJ P,
;dot handler
RDOT: MOVEM A,ORGSGN ;INCASE SOMETHING ELSE DEFINED AS "."
PUSHJ P,TYID
LDB B,DOTFLD
JRST DOTAB(B)
DOTAB: PUSHJ P,COMMENT ;0 comment
JRST RDOT+1 ;1 null
JRST RDOT2 ;2 delimit
JRST RDOT2 ;3 dot
JRST RDOT2 ;4 e
MOVEI B,0 ;5 digit
IDPB B,C
TLO T,SAWDOT
JRST RDNUM
PAGE
;string scanner
STRTAB: PUSHJ P,COMMENT ;0 comment
JRST RDSTR+1 ;1 null
JRST STR2 ;2 delimit
RDSTR: IDPB A,C ;3 string element
PUSHJ P,TYID
LDB B,STRFLD
JRST STRTAB(B)
STR2: MOVEI A,DBLQT
HRRI R,STRCLS ;string
IDPB A,C
NOINTR: PUSHJ P,IDEND ;no intern
PUSHJ P,IDSUB
JRST PNAMAK
;identifier scanner
IDTAB: PUSHJ P,COMMENT ;0
JRST RDID+1 ;1 null
JRST MAKID ;2 delimit
PUSHJ P,TYI ;3 /
RDID: IDPB A,C ;4 letter or digit
PUSHJ P,TYID
LDB B,IDFLD
JRST IDTAB(B)
PAGE
;LINEREAD - RETURNS ALL THE EXPRESSIONS ON ONE LINE AS A LIST
;
LINRD: SETZM OLDCH ;Shouldn't be any left-over chrs at start of line.
LINRDA: PUSHJ P,READ
HRRZ B,A
SKIPE SMAC ;CHECK THE SPLICE LIST
JRST LRMORE
SKIPN A,OLDCH
LRTY: PUSHJ P,TYID ;NEED A CHARACTER
MOVEM A,OLDCH ;SAVE IT
LDB C,RATFLD ;THIS KLUDGE IS TO AVOID MAKING ANOTHER TABLE ENTRY
CAIN C,7 ;SPECIAL CHECK FOR "."
JRST LRTY1 ;IGNORE IT
CAILE C,3 ;ELIMINATE MOST POSSIBILITIES
JRST LRMORE ;MORE ON THE LINE
JUMPE C,LREND ;END LINE ON COMMENT - THINK ABOUT IT, ITS RIGHT
LDB C,RDFLD
JRST LR1(C)
LR1: JRST LPIG ;0 MORE TO FIGURE OUT
JRST LRTY1 ;1 IGNORE
JRST LRMORE ;2 MORE ON THE LINE
SUBI A,ALTMOD ;3 CHECK ALTMOD
JUMPN A,LRTY1 ;4 IGNORE "]" AND "."
JUMPN A,LRMORE ;5 MORE ON "@"
JRST LREND
LPIG: CAIN A,"(" ;THESE SPECIAL CHECK COULD SCREW UP READ MACROS
JRST LRMORE
CAIE A,TAB
CAIL A,40 ;READ MORE IF SPACE, COMMA, OR TAB
JRST [ HRLI B,-1 ;SET SPQCE FLAG AND TRY AGAIN
JRST LRTY]
CAIE A,CR ;ALWAYS IGNORE CR.S
TLZE B,-1 ;EOL - IF SPACE FLAG THEN DO A PEEKC
JRST LRTY
LREND: HRRZ A,B ;FINALLY GOT THERE
JRST NCONS
LRMORE: HRLI B,0
PUSH P,B ;MORE TO GO, PUSH
PUSHJ P,LINRDA ;AND CALL YOURSELF
POP P,B
JRST XCONS
LRTY1: HRLI B,0 ;CLEAR SPACE FLAG
JRST LRTY
PAGE
;## FUNCTIONS TO READ A FILE.EXT
;## READ A FILE.EXT FROM THE UFD
FLTYIA: XCT TYI2 ;## GET NEXT WORD, IGNORE OLDCH
PUSHJ P,TYI2X ;## INPUT SOME MORE
ILDB A,@TYI3 ;## AND LOAD WORD
POPJ P,
RDFIL1: PUSHJ P,FLTYIA ;## FILE NAME NOT THERE, SKIP OVER EXT
RDFILE: SETZM NOINFG ;## ## INTERN
PUSHJ P,FLTYIA ;## GET FILE NAME WORD
PUSHJ P,SIXATM ;## MAKE IT AN ATOM
JUMPE A,RDFIL1 ;## A←-1 IF EMPTY
PUSH P,A
PUSHJ P,FLTYIA ;## GET EXTENSION
HRRI A,0 ;## CLEAR RH
PUSHJ P,SIXATM
JUMPE A,POPAJ ;## NO EXTENSION, RETURN
POP P,B ;## GET FILE BACK
JRST XCONS ;## RETURN FILE.EXT
COMMENT ⊗
RDFILE: OUTSTR [ASCIZ /
The function RDFILE is temporarily disabled. Please tell DWP about this./]
ERR1 [SIXBIT /!/]
;## ROUTINE TO TAKE ONE WORD OF SIXBIT AND MAKE IT AN ATOM
;## IGNORES TRAILING BLANKS, BUT INCLUDES INSERTED BLANKS. NO
;## READ MACROS, ETC.
SIXATM: SKIPN T,A
POPJ P, ;RETURN NIL IF WORD EMPTY
MOVE TT,[POINT 7,A]
SETZB A,B ;## CLEAR A
SIXAT2: LDB C,[POINT 6,T,5]
LSH T,6
HRRI C,40(C) ;## ADD 40 TO C
IDPB C,TT
JUMPN T,SIXAT2 ;## DONE IF T EMPTY
PUSHJ P,FWCONS
PUSH P,A
MOVE A,B
JUMPE A,SIXAT3
PUSHJ P,FWCONS
PUSHJ P,NCONS
SIXAT3: POP P,B
PUSHJ P,XCONS
JRST PNGNK1 ;Make the atom.
⊗
SIXATM: JUMPE A,CPOPJ ;Make an atom from the SIXBIT in A. Return NIL if none.
MOVEM A,SIXAT1
MOVE A,[POINT 6,SIXAT1]
MOVEM A,SIXAT2#
MOVEI A,SIXAT3
JRST READ0N
SIXAT3: ILDB A,SIXAT2 ;(READ calls us instead of TYI.)
ADDI A,40 ;Convert to ASCII.
POPJ P,
REMOTE {
SIXAT1: 0
0 }
;NEW AND SUPER BITCHEN READ MACROS
;
RMACRO:
IFN ALVINE,<
SKIPE PSAV1 ;$$ ARE WE IN ALVINE?
JRST RATOM2 ;$$ YES, IGNORE>
RMAC2: IDPB A,C ;$$ CONVERT THE CHAR. TO AN ATOM
PUSHJ P,IDEND ;$$
PUSHJ P,INTER0 ;$$
MOVEM A,T ;$$ SAVE ATOM IN CASE OF ERROR
MOVEI B,READMACRO(S) ;$$ GET THE FUNCTION NAME
PUSHJ P,GET ;$$
JUMPE A,RMERR ;$$ UNDEFINED READ MACRO
PUSHJ P,NCONS ;$$ CONVERT TO A FORM
PUSH P,PSAV ;$$
PUSHJ P,EVAL ;$$ EVALUATE THE FORM
POP P,PSAV ;$$
POPJ P, ;$$ RETURN
;SPECIAL PROCESSING OF SPLICE MACROS
SMACRO:
IFN ALVINE,<
SKIPE PSAV1 ;$$ ARE WE IN ALVINE?
JRST RATOM2 ;$$ YES, IGNORE>
PUSHJ P,RMAC2 ;$$ EVALUATE THE MACRO
MOVEM A,SMAC ;$$ SAVE THE SPLICE LIST
JRST RATOM ;$$ START OVER
;GET AN ITEM OFF OF THE SPLICE LIST
PSMAC: MOVE A,SMAC ;$$
PUSHJ P,ATOM ;$$ IS SPLICE LIST AN ATOM?
JUMPN A,[ MOVE A,SMAC ;$$ YES, SIMULATE . <ATOM>
PUSHJ P,NCONS ;$$
MOVEM A,SMAC ;$$
MOVEI B,4 ;$$
JRST RATOM3+1] ;$$
MOVE B,@SMAC ;$$
HLRZ A,B ;$$ RETURN NEXT ITEM OF SPLICE LIST
HRRZM B,SMAC ;$$ ADVANCE SPLICE LIST
POPJ P, ;$$ RETURN
PAGE
;number scanner
NUMTAB: PUSHJ P,COMMENT ;0 comment
JRST RDNUM+1 ;1 null
JRST NUMAK ;2 delimit
JRST RDNDOT ;3 dot
JRST RDE ;4 e
RDNUM: IDPB A,C ;5 digit
PUSHJ P,TYID
LDB B,NUMFLD
JRST NUMTAB(B)
RDNDOT: TLOE T,SAWDOT
JRST NUMAK ;two dots - delimit
MOVEI A,0
JRST RDNUM
RDNMIN: TLO T,MINSGN
RDNPLS: MOVEM A,ORGSGN# ;SAVE SIGN IN CASE OF BACKUP
JRST RDNUM+1
;exponent scanner
RDE: CAME C,ORGSTK ;FOR +E AND -E TYPE OF ATOMS
JRST .+3
MOVEM A,OLDCH
JRST KLDG1
TLO T,EXP
MOVEI A,0
IDPB A,C
PUSHJ P,TYID
CAIN A,"-"
TLOA T,NEXP
CAIN A,"+"
JRST RDE2+1
JRST RDE2+2
EXPTAB: PUSHJ P,COMMENT ;0
JRST RDE2+1 ;1 null
JRST NUMAK ;2 delimit
RDE2: IDPB A,C ;3 digit
PUSHJ P,TYID
LDB B,EXPFLD
JRST EXPTAB(B)
PAGE
;semantic routines
;identifier interner and builder
IDEND: TDZA A,A
IDEND1: IDPB A,C
TLNE C,760000
JRST IDEND1
POPJ P,
MAKID: MOVEM A,OLDCH
PUSHJ P,IDEND
SKIPE NOINFG
JRST NOINTR ;dont intern it
INTER0: PUSHJ P,IDSUB
MOVEI AR1,1
PUSHJ P,INTER1 ;is it in oblist
POPJ P, ;found
PUSHJ P,PNAMAK ;not there
MAKID2:
MOVE C,CURBUC# ;
HLRZ B,@RHX2
PUSHJ P,CONS ;cons new atom into the oblist
HRLM A,@RHX2
JRST CAR
;pname unmaker
PNAMUK:
MOVEI B,PNAME(S)
PUSHJ P,GET
JUMPE A,NOPNAM
MOVE C,SP
PNAMU3: HLRZ B,(A)
PUSH C,(B)
HRRZ A,(A)
JUMPN A,PNAMU3
SETZM 1(C)
POPJ P,
;idsub constructs a iowd pointer for a print name
IDSUB: HRRZS C
CAML C,JRELO ;top of spec pdl
JRST SPDLOV
MOVNS C
ADDI C,(SP)
HRLI C,1(SP)
MOVSM C,IDPTR#
POPJ P,
;identifier interner
REMOTE<
INT1: BCKETS
RHX2:
XXX1: XWD B+1,OBTBL>
INTER1: MOVE B,1(SP) ;get first word of pname
LSH B,-1 ;right justify it
IDIV B,INT1 ;compute hash code
PUSH P,C ;## SAVE C
HRRZ C,VOBLIST(S) ;## THIS GETS THE CURRENT VALUE OF OBLIST(THE ATOM)
HRRM C,RHX2 ;## ASSUMES THAT ALL REFERENCE TO OBLIST GOES
HRRM C,RHX5 ;## IE INTERN, REMOB ETC GOES THROUGH THIS SECTION.
POP P,C ;##RHX2 AND RHX5 ARE HOPEFULLY THE ONLY TWO WORDS
;##WHICH ARE USED TO REFERENCE TABLE 3/28/73
HLRZ TT,@RHX2 ;get bucket
MOVEM B+1,CURBUC ;save bucket number
MOVE T,TT
JRST MAKID1
MAKID3: MOVE TT,T ;save previous atom
HRRZ T,(T) ;get next atom
MAKID1: JUMPE T,CPOPJ1 ;not in oblist
HLRZ A,(T) ;next id in oblist
MAKID4: MOVEI B,PNAME(S) ;## USE GET FOR GETTING PNAME
PUSHJ P,GET ;## (GET ATOM @PNAME)
JUMPE A,NOPNAM ;## NO PRINT NAME
MOVE C,IDPTR ;found pname
MAKID5: JUMPE A,MAKID3 ;not the one
MOVS A,(A)
MOVE B,(A)
ANDCAM AR1,(C) ;clear low bit
CAME B,(C)
JRST MAKID3 ;not the one
HLRZ A,A ;ok so far
AOBJN C,MAKID5
JUMPN A,MAKID3 ;not the one
HLRZ A,(T) ;this is it
HLRZ B,(TT)
HRLM A,(TT)
HRLM B,(T)
POPJ P,
;pname builder
PNAMAK: MOVE T,IDPTR
PUSHJ P,NCONS
MOVE TT,A
MOVE C,A
PNAMB: MOVE A,(T)
TRZ A,1 ;clear low bit!!!!!
PUSHJ P,FWCONS
PUSHJ P,NCONS
HRRM A,(TT)
MOVE TT,A
AOBJN T,PNAMB
MOVE A,C
HRLZS (A)
JRST PNGNK1+1
PAGE
;number builder
NUMAK: MOVEM A,OLDCH
HRRI R,NUMCLS ;number
CAME C,ORGSTK ;BIG KLUDGE FOR + AND -
JRST .+5
KLDG1: MOVE A,ORGSGN ;ENTER HERE TO BACK UP IN THE CASE OF +E OR -E
IDPB A,C
PUSHJ P,TYIA
JRST RDID+2
MOVEI A,0
IDPB A,C
IDPB A,C
HRRZS C
CAML C,JRELO ;top of spec pdl
JRST SPDLOV
MOVSI C,(<POINT 7,0,35>)
HRRI C,(SP)
TLNE T,SAWDOT+EXP
JRST NUMAK2 ;decimal number or flt pt
MOVE A,VIBASE(S) ;ibase integrer
SUBI A,INUM0
PUSHJ P,NUM
NUMAK4:
MOVEI B,FIXNUM(S)
NUMAK6: TLNE T,MINSGN
MOVNS A
JRST MAKNUM
NUMAK2: PUSHJ P,NUM10
MOVEM A,TT
TLNN T,SAWDOT
JRST [ PUSHJ P,FLOAT ;flt pt without fraction
MOVE TT,A
JRST NUMAK3]
PUSHJ P,NUM10 ;fraction part
EXCH A,TT
TLNN T,EXP
JUMPE AR2A,NUMAK4 ;no exponent and no fraction
PUSHJ P,FLOAT
EXCH A,TT
PUSHJ P,FLOAT
MOVEI AR1,FT01
PUSHJ P,FLOSUB
FMPR A,B
FADRM A,TT
NUMAK3: PUSHJ P,NUM10 ;exponent part
MOVE AR2A,A
MOVEI AR1,FT-1
TLNE T,NEXP
MOVEI AR1,FT01 ;-exponent
PUSHJ P,FLOSUB
FMPR TT,B ;positive exponent
MOVEI B,FLONUM(S)
MOVE A,TT
JFCL 10,FLOOV
JRST NUMAK6
FLOSUB: MOVSI B,(1.0)
TRZE AR2A,1
FMPR B,(AR1)
JUMPE AR2A,CPOPJ
LSH AR2A,-1
SOJA AR1,FLOSUB+1
;variable radix integer builder
CLINUM:MOVE C,[POINT 7,LINUM] ;(Special entry for PGLINE)
NUM10: MOVEI A,TEN
NUM: HRRM A,NUM1
JFCL 10,.+1 ;clear carry0 flag
SETZB A,AR2A
NUM2: ILDB B,C
JUMPE B,CPOPJ ;done
IMUL A,NUM1#
ADDI A,-"0"(B)
NUM3: JFCL 10,FIXOV ;bignums change this to jfcl 10,rdbnm
AOJA AR2A,NUM2
INTERN: MOVEM A,AR2A
PUSHJ P,PNAMUK
PUSHJ P,IDSUB
MOVEI AR1,1
PUSHJ P,INTER1 ;is it in oblist
POPJ P, ;found it
MOVE A,AR2A ;not there
JRST MAKID2 ;put it there
REMOTE<
RHX5:
XXX2: XWD B,OBTBL>
REMOB: JUMPE A,FALSE
MOVEI AR1,1
PUSH P,A
HLRZ A,(A)
PUSHJ P,INTERN
HLRZ B,@(P)
CAME A,B
JRST REMOB2
HRRZ B,CURBUC
HLRZ C,@RHX5
HLRZ T,(C)
CAMN T,A
JRST [ HRRZ TT,(C)
HRLM TT,@RHX5
JRST REMOB2]
REMOB3: MOVE TT,C
HRRZ C,(C)
HLRZ T,(C)
CAME T,A
JRST REMOB3
HRRZ T,(C)
HRRM T,(TT)
REMOB2: POP P,A
HRRZ A,(A)
JRST REMOB
PAGE
;READ, CONTINUED.
;ROUTINE TO ALLOW ARBITRARY MODIFICATION AND READING OF THE
;READ CHARACTER-TABLE BY LISP FUNCTIONS
;TAKES TWO ARGUMENTS A,B
; IF B ← NIL IT RETURNS THE CONTENTS OF CHARACTER TABLE
; LOCATION SPECIFIED BY A
; OTHERWISE IT CHANGES THE CHARACTER TABLE ENTRY SPECIFIED BY A
; TO THE BIT PATTERN SPECIFIED BY B, AND RETURNS THE
; PREVIOUS VALUE
MODCHR: PUSH P,B ;$$SAVE BIT PATTERN FOR TABLE
PUSHJ P,NUMVAL ;$$GET POSITION IN TABLE
POP P,B ;$$
MOVE T,CHRTAB(A) ;$$GET OLD TABLE VALUE
JUMPE B,MCEXIT ;$$IF B←NIL THEN JUST RETURN OLD TABLE VALUE
PUSH P,A ;$$SAVE TABLE POSITION
MOVEI A,(B) ;$$
PUSHJ P,NUMVAL ;$$GET NEW BIT PATTERN
POP P,B ;$$GET TABLE POSITION
MOVEM A,CHRTAB(B) ;$$CHANGE TABLE
MCEXIT: MOVE A,T ;$$RETURN OLD TABLE VALUE
JRST FIX1A ;$$CONVERT TO BINARY AND EXIT
;FUNCTION TO DETERMINE THE ASCII VALUE OF A CHARACTER
; CHRVAL TAKES AN ATOM AS ITS ARGUMENT AND USES THE FIRST
; CHARACTER OF THE PRINT NAME
CHRVAL: MOVEI B,PNAME(S) ;$$ GET PRINT NAME
PUSHJ P,GET ;$$
HLRZ A,(A) ;$$
MOVE A,(A) ;$$ FIRST WORD OF PRINT NAME
LSH A,-35 ;$$ SHIFT TO GET FIRST CHARACTER
JRST FIX1A ;$$ CONVERT TO INTEGER
;FUNCTION TO SET BITS FOR A READ MACRO
; A IS THE CHAR. ATOM AND B ARE THE STATUS BITS,
; IF B←NIL NO MODIFICATION IS MADE
; THE OLD STATUS BITS ARE RETURNED
SETCHR: MOVE TT,B ;$$
PUSHJ P,CHRVAL ;$$ CONVERT CHAR. TO INUM
MOVEI B,-INUM0(A) ;$$ CONVERT INUM TO BINARY
LDB A,[POINT 5,CHRTAB(B),5] ;$$ LOAD OLD BITS
JUMPE TT,FIX1A ;$$ NO CHANGE IF B ← NIL
MOVEI TT,-INUM0(TT) ;$$ CONVERT STATUS TO BINARY
DPB TT,[POINT 5,CHRTAB(B),5] ;$$ SET NEW BITS
JRST FIX1A ;$$ RETURN
PAGE
SUBTTL LISP INTERPRETER SUBROUTINES
CADDDR: SKIPA A,(A)
CADDAR: HLRZ A,(A)
CADDR: SKIPA A,(A)
CADAR: HLRZ A,(A)
CADR: SKIPA A,(A)
CAAR: HLRZ A,(A)
CAR: HLRZ A,(A)
POPJ P,
CDDDDR: SKIPA A,(A)
CDDDAR: HLRZ A,(A)
CDDDR: SKIPA A,(A)
CDDAR: HLRZ A,(A)
CDDR: SKIPA A,(A)
CDAR: HLRZ A,(A)
CDR: HRRZ A,(A)
POPJ P,
CAADDR: SKIPA A,(A)
CAADAR: HLRZ A,(A)
CAADR: SKIPA A,(A)
CAAAR: HLRZ A,(A)
JRST CAAR
CDADDR: SKIPA A,(A)
CDADAR: HLRZ A,(A)
CDADR: SKIPA A,(A)
CDAAR: HLRZ A,(A)
JRST CDAR
CAAADR: SKIPA A,(A)
CAAAAR: HLRZ A,(A)
JRST CAAAR
CDDADR: SKIPA A,(A)
CDDAAR: HLRZ A,(A)
JRST CDDAR
CDAADR: SKIPA A,(A)
CDAAAR: HLRZ A,(A)
JRST CDAAR
CADADR: SKIPA A,(A)
CADAAR: HLRZ A,(A)
JRST CADAR
PAGE
QUOTE: HLRZ A,(A) ;car and quote duplicated for backtrace
POPJ P,
ASCIIVAL: ;Get chr. code for first letter of atom's PNAME.
MOVEI B,PNAME(S)
PUSHJ P,GET
HLRZ A,(A)
LDB A,[POINT 7,(A),6]
JRST FIXI
AASCII: PUSHJ P,NUMVAL
AASC1: LSH A,=29
PUSHJ P,FWCONS
PUSHJ P,NCONS
PNGNK1: PUSHJ P,NCONS
MOVEI B,PNAME(S)
PUSHJ P,XCONS
ACONS: ;Reserve cell before atom head for any future VALUE cell !(DWP AUG 74)
PUSHJ P,MAKD2X ;Try to do it; go directly to MAKD2C on success.
SETOM GCGAGV
PUSHJ P,AGC ;No adjacent free cells free list. Try to make some.
SETZM GCGAGV
PUSHJ P,MAKD2X ;NOTE: goes directly to MAKD2C if it succeeds !
ERR1 [SIXBIT /YOU NEED MORE FREE STORAGE. EXPAND CORE, AND PLEASE MAIL
A NOTE TO DWP GIVING THE AMOUNT OF `FREE STG. AVAILABLE' PRINTED JUST ABOVE. !/]
MAKD2B: SKIPA B,C ; Find two adjacent free cells and move atom to upper one.
MAKD2X: MOVEI B,F ;Enter here.
HRRZ C,(B) ;Get ptr. to next free cell.
JUMPE C,CPOPJ ;End of free list.
SUBI C,1
CAME C,1(C) ;Is the following free cell just below this one ?
AOJA C,MAKD2B ;No.
HRL B,(C) ;Yes. Remove both from the free list.
HLRZM B,(B)
MOVEM F,1(C) ;`cons' the upper cell onto head of
MOVEI F,1(C) ; free list.
MOVEI B,UNBOUND(S)
MOVEM B,(C) ;Initialize the potential VALUE cell to UNBOUND.
MAKD2C: SUB P,[1,,1] ;Remove the extra return address !
NUMCNS: TROA B,-1
NCONS: TRZA B,-1
XCONS: EXCH B,A
CONS: AOS CONSVAL
HRL B,A
SKIPN A,F
JRST [ HLR A,B
PUSHJ P,AGC
JRST .-1]
MOVE F,(F)
MOVEM B,(A)
POPJ P,
;new consing routines-not finished yet
;acons: troa b,-1
;ncons: trz b,-1
;cons: exch b,a
;xcons: hrl a,b
; exch a,(f)
; exch a,f
; popj p,
CONSP: JUMPE A,CPOPJ ;## DONE IF NIL
CAILE A,INUMIN
JRST FALSE
HLLE B,(A)
AOJE B,FALSE
IFN NONUSE <JRST TRUE> ;## T IF NONUSEFUL DESIRED
IFE NONUSE <POPJ P,> ;## THE CELL OTHERWISE
PATOM: CAIL A,@FSTOP
JRST TRUE
CAIL A,@FSBOT
ATOM: CAILE A,INUMIN
JRST TRUE
JUMPE A,TRUE ;## FAST CHECK FOR NIL
CAIGE A,@FSTOP ;## LO-END OF FWS, CAN'T ADD TO 0
HLLE A,(A)
AOJE A,TRUE
JRST FALSE
PAGE
NEQ: CAMN A,B
JRST FALSE
JRST TRUE
EQ: CAMN A,B
JRST TRUE
JRST FALSE
LENGTH: MOVEI B,0
LNGTH1: CAIE A,NIL ;## DONE IF NIL
CAIL A,@FWSO ;## FWSO IS FULL SPACE ORIGIN,
;## ELIMINATE ILL MEM REF
JRST FIX1
HLLE C,(A)
AOJE C,FIX1
HRRZ A,(A)
AOJA B,LNGTH1
LAST: HRRZ B,(A)
CAIE B,NIL ;## IF NIL DONE
CAIL B,@FWSO ;## ANOTHER POTENTIAL ILL MEM GONE
POPJ P,
HLLE B,(B)
AOJE B,CPOPJ
HRRZ A,(A)
JRST LAST
;(LITATOM X) ← (AND (ATOM X) (NOT (NUMBERP X)))
LITATOM:MOVE B,A
PUSHJ P,ATOM
JUMPE A,CPOPJ
MOVE A,B
PUSHJ P,NUMBERP
JRST NOT
PAGE
;MORE INTERPRETER ROUTINES
;NEW RPLACD AND RPLACA WHICH CHECK SO AS NOT TO CLOBBER NIL AND ATOMS
RPLACA: CAIE A,NIL ;## TEST FOR NIL
CAILE A,INUMIN ;$$
JRST RPAERR ;$$ ATTEMPT TO RPLACA A SMALL NUMBER
HLL A,(A) ;$$TEST FOR OTHER ATOMS
TLC A,-1 ;$$
TLZN A,-1 ;$$ATOM CARS ARE -1
JRST RPAERR ;$$ATTEMPT TO RPLACA AN ATOM
HRLM B,(A) ;$$STANDARD CODE FOR RPLACA
POPJ P, ;$$
RPLACD: CAIG A,INUMIN ;$$CHECK FOR SMALL BER
JUMPN A,.+2 ;$$CHECK FOR NIL
JRST RPDERR ;$$ATTEMPT TO RPLACD NIL OR A SMALL NUMBER
HRRM B,(A) ;$$OLD RPLACD CODE
POPJ P, ;$$
ZEROP: PUSHJ P,NUMVAL
NOT:
NULL: JUMPN A,FALSE
TRUE:
MOVEI A,TRUTH(S)
POPJ P,
FW0CNS: MOVEI A,0
FWCONS: JUMPN FF,FWC1
EXCH A,FWC0#
PUSHJ P,AGC
EXCH A,FWC0
FWC1: EXCH A,(FF)
EXCH A,FF
POPJ P,
PAGE
SASSOC: PUSHJ P,SAS1
JCALLF 0,(C)
POPJ P,
SAS0: HLRZ B,T
SAS1: JUMPE B,CPOPJ
MOVS T,(B)
MOVS TT,(T)
CAIE A,(TT)
JRST SAS0
HRRZ A,T
CPOPJ1: AOS (P)
POPJ P,
ASSOC: PUSHJ P,SAS1
FALSE: MOVEI A,NIL
CPOPJ: POPJ P,
REVERSE: MOVE T,A
MOVEI A,0
JUMPE T,CPOPJ
HLRZ B,(T)
HRRZ T,(T)
PUSHJ P,XCONS
JUMPN T,.-3
POPJ P,
REMPROP: HRRZ T,(A)
MOVS TT,(T)
CAIN B,(TT)
JRA TT,REMP1
HLRZ A,TT
HRRZ T,(A)
JUMPN T,REMPROP+1
JRST FALSE
REMP1: HRRM TT,(A)
JRST TRUE
PAGE
;## IF WE ARE USING NEW NIL, THEN GET IS FOR SYSTEM ONLY AND
;## USRGET IS THE USERS. IF NEW NIL, THEN GET MUST GET NIL'S
;## PROPERTY LIST
IFE OLDNIL<
USRGET: JUMPE A,CPOPJ ;## ALWAYS NIL>
GET:
IFE OLDNIL< CAIE A,NIL
SKIPA A,NILPRP>
HRRZ A,(A)
GET1: MOVS D,(A)
CAIN B,(D)
JRST CADR
HLRZ A,D
HRRZ A,(A)
JUMPN A,GET1
POPJ P,
GETL: JUMPE B,FALSE ;$$ NIL LIST - NIL ANSWER
IFE OLDNIL <JUMPE A,CPOPJ> ;## TEST FOR NIL
HRRZ A,(A)
GETL0: HLRZ T,(A)
MOVE C,B
GETL1: MOVS TT,(C)
CAIN T,(TT)
POPJ P,
HLRZ C,TT
JUMPN C,GETL1
HRRZ A,(A)
HRRZ A,(A)
JUMPN A,GETL0
POPJ P,
NUMBERP: CAILE A,INUMIN
JRST TRUE
HLLE T,(A)
AOJN T,FALSE
HRRZ A,(A)
HLRZ A,(A)
CAIE A,FIXNUM(S)
CAIN A,FLONUM(S)
JRST TRUE
NUMBP2: JRST FALSE ;bignums change this to JRST BIGNP
STRINGP: MOVE B,A ;← T IF A IS A STRING
PUSHJ P,ATOM
JUMPE A,CPOPJ
MOVE A,B
PUSHJ P,NUMBERP ;MUST NO BE A NUMBER
JUMPN A,FALSE
MOVE A,B
PUSHJ P,CHRVAL ;GET THE FIRST CHARACTER
CAIE A,42+INUM0 ;CHECK FOR "
JRST FALSE
JRST TRUE
PUTPROP:
IFN OLDNIL <MOVE T,A>
IFE OLDNIL <SKIPN T,A ;## CAN'T PUTPROP TO NIL
ERR1 [SIXBIT /CAN'T PUT PROP ON NIL !/]>
HRRZ A,(A)
CSET3: MOVS TT,(A)
HLRZ A,TT
CAIN C,(TT)
JRST CSET2
HRRZ A,(A)
JUMPN A,CSET3
CAIN C,VALUE(S)
PUSHJ P,CSTFOO
HRRZ A,(T)
PUSHJ P,XCONS
HRRZ B,C
PUSHJ P,XCONS
HRRM A,(T)
JRST CADR
CSET2: CAIE C,VALUE(S)
JRST CSET1
HRRZ T,(B)
HLRZ A,(A)
HRRM T,(A)
JRST PROG2
CSET1: HRLM B,(A)
PROG2: MOVE A,B
PROG1: POPJ P,
CSTFOO: ;OUTSTR [ASCIZ/$$$ PUTPROP VALUE $$$/]
MOVE A,(B) ;Try to do the right thing.
MOVEM A,-1(T)
MOVEI B,-1(T) ;Value cell is just before atom (DWP AUG 74)
POPJ P,
DEFPROP:HRRZ B,(A)
HRRZ C,(B)
HLRZ A,(A)
HLRZ B,(B)
HLRZ C,(C)
PUSH P,A
PUSHJ P,PUTPROP
JRST POPAJ
EQUAL: MOVE C,P
EQUAL1: CAMN A,B
JRST TRUE
MOVE T,A
MOVE TT,B
PUSHJ P,ATOM
EXCH A,B
PUSHJ P,ATOM
CAMN A,B
JRST EQUAL3
EQUAL4: MOVE P,C
JRST FALSE
EQUAL3: JUMPN A,EQ2
PUSH P,T
PUSH P,TT
HLRZ A,(T)
HLRZ B,(TT)
PUSHJ P,EQUAL1
JUMPE A,EQUAL4
POP P,B
POP P,A
HRRZ A,(A)
HRRZ B,(B)
JRST EQUAL1
EQ2: PUSH P,T
MOVE A,T
PUSHJ P,NUMBERP
JUMPE A,EQUAL4
MOVE A,TT
PUSHJ P,NUMBERP
JUMPE A,EQUAL4
MOVE A,(P)
MOVEM C,(P)
MOVE B,TT
JSP C,OP
JUMPL COMP3
JUMPL COMP3
COMP3: POP P,C
CAME A,TT
JRST EQUAL4
JRST TRUE
PAGE
SUBST: PUSH P,A
HRLM B,(P)
HRRZM P,SUBAS#
PUSHJ P,SUBS0A
JRST POPBJ
SUBS0A: HLRZ B,@SUBAS
PUSH P,C
MOVE A,C
PUSHJ P,EQUAL
POP P,C
JUMPN A,SUBS5
CAIE C,NIL ;## TEST FOR NIL
CAILE C,INUMIN
JRST EV6A
HLLE T,(C)
AOJN T,SUBS2
EV6A: SKIPA A,C
SUBS5: HRRZ A,@SUBAS
POPJ P,
SUBS2: PUSH P,C
HLRZ C,(C)
PUSHJ P,SUBS0A
EXCH A,(P)
HRRZ C,(A)
PUSHJ P,SUBS0A
POP P,B
JRST XCONS
COPY: PUSH P,A
PUSHJ P,ATOM
JUMPN A,POPAJ
HLRZ A,@(P)
PUSHJ P,COPY
EXCH A,(P)
HRRZ A,(A)
PUSHJ P,COPY
POP P,B
JRST XCONS
; NTHCHAR ← THE BTH CHARACTER OF A.
NTHCHAR:MOVE T,B
SUBI T,INUM0
JUMPE T,FALSE ;FAIL IF ← 0
PUSH P,A
MOVEM T,ORGSGN
JUMPG T,NTH3
PUSHJ P,%FLATSIZEC
MOVEI T,1-INUM0(A)
ADDB T,ORGSGN
NTH3: MOVE A,(P)
PUSHJ P,LITATOM
JUMPN A,NTH4
POP P,A
HRROI R,NTH5 ;I HOPE THIS IS RIGHT
PUSHJ P,PRINTA
HLRZ A,ORGSGN
JRST NTH6
NTH5: SOSN ORGSGN
HRLOM A,ORGSGN
POPJ P,
NTH4: MOVE T,ORGSGN
POP P,A
MOVEI B,PNAME(S)
PUSHJ P,GET
JUMPE A,CPOPJ ;FAIL IF NO PRINT NAME
NTH1: CAIG T,5
JRST NTH2
HRRZ A,(A)
JUMPE A,FALSE ;FAIL IF NO NTH CHARACTER
SUBI T,5
JRST NTH1
NTH2: HLRZ A,(A)
IMULI T,-7
LSH T,14
ADDI T,440700
HRL A,T
LDB A,A
JUMPE A,FALSE
NTH6: PUSHJ P,AASCII+1 ;CONVERT TO AN ATOM
JRST INTERN ;INTERN IT
PAGE
NCONC: TDZA R,R
APPEND: MOVEI R,.APPEND-.NCONC
JUMPE T,FALSE
POP P,B
APP2: AOJE T,PROG2
POP P,A
PUSHJ P,.NCONC(R)
MOVE B,A
JRST APP2
.NCONC: JUMPE A,PROG2
MOVE TT,A
MOVE C,TT
HRRZ TT,(C)
JUMPN TT,.-2
HRRM B,(C)
POPJ P,
.APPEND: JUMPE A,PROG2
MOVEI C,AR1
MOVE TT,A
APP1: HLRZ A,(TT)
PUSH P,B
PUSHJ P,CONS ;saves b
POP P,B
HRRM A,(C)
MOVE C,A
HRRZ TT,(TT)
JUMPN TT,APP1
JRST SUBS4
PAGE
IFN NONUSE<MEMBER:
>
MEMB0: MOVEM A,SUBAS#
MEMB1: JUMPE B,FALSE
MOVEM B,SUBBS#
MOVE A,SUBAS
HLRZ B,(B)
PUSHJ P,EQUAL
JUMPN A,CPOPJ
MOVE B,SUBBS
HRRZ B,(B)
JRST MEMB1
IFE NONUSE<MEMQ:
>
MEMB: EXCH A,B ;## NEW MEMQ THAT RETURN TAIL
JUMPE A,FALSE
MEMBX1: MOVS C,(A)
CAIN B,(C)
POPJ P,
HLRZ A,C
CAMGE A,FWSO ;##THIS WILL ELIMINATE MOST (MAYBE ALL)
;## ILLEGAL MEM REFS FROM MEMQ
;##AND ASSOCIATED ROUTINES. FWSO IS FWS ORIGIN
JUMPN A,MEMBX1
POPJ P,
;NEW MEM-FUNCTIONS THAT RETURN THE TAIL OF THE LIST STARTING WHERE
; THE ELEMENT IS FOUND
IFE NONUSE<MEMBER:
>
MEMBR.: PUSHJ P,MEMB0
SKIPE A
MOVE A,SUBBS
POPJ P,
IFN NONUSE<
MEMQ: PUSHJ P,MEMB
SKIPE A
JRST TRUE
POPJ P,
;AND OR FUNCTIONS (AND#, OR#) THAT RETURN THE EXPRESSION
; THAT CAUSED THE FUNCTION TO EVALUATE TO TRUE
AND.: PUSHJ P,AND
SKIPA
OR.: PUSHJ P,OR
HRRZ A,2(P)
POPJ P,
>
AND:
HRLI A,TRUTH(S)
OR: HLRZ C,A
PUSH P,C
ANDOR: HRRZ C,A
JUMPE C,AOEND
MOVSI C,(<SKIPE (P)>)
TLNE A,-1
MOVSI C,(<SKIPN (P)>)
XCT C
JRST AOEND
MOVEM A,(P)
HLRZ A,(A)
PUSHJ P,EVAL
EXCH A,(P)
HRR A,(A)
JRST ANDOR
AOEND: POP P,A
IFN NONUSE <
SKIPE A
MOVEI A,TRUTH(S)
>
POPJ P,
GENSYM: MOVE B,[POINT 7,GNUM,34]
MOVNI C,5 ;Increment the letter if the number overflows !
MOVEI TT,"0"
GENSY2: LDB T,B
AOS T
DPB T,B
CAIG T,"9"
JRST GENSY1
DPB TT,B
ADD B,[XWD 70000,0]
AOJN C,GENSY2
GENSY1: MOVE A,GNUM
PUSHJ P,FWCONS
PUSHJ P,NCONS
JRST PNGNK1
REMOTE<
GNUM: ASCII /G0000/>
CSYM: HLRZ A,(A)
PUSH P,A
MOVEI B,PNAME(S)
PUSHJ P,GET
JUMPE A,NOPNAM
HLRZ A,(A)
MOVE A,(A)
MOVEM A,GNUM
JRST POPAJ
;LIST and ILIST (and EELS)
LIST: MOVEI B,CEVAL(S) ;LIST evaluates the top level elements of its
PUSH P,B ; arg. and returns the values as a list.
PUSH P,A
MOVNI T,2
JRST MAPCAR
EELS: HLRZ TT,(T) ;interpret lsubr call
HRRZ A,(AR1) ;Get CDR of the form.
ILIST: MOVEI T,0 ;ILIST (called with JSP TT,) stacks the values and returns a
ILIST1: JUMPE A,(TT) ; negative count of them in T.
PUSH P,A
HLRZ A,(A)
PUSH P,TT
HRLM T,(P)
PUSHJ P,EVAL ;EVALUATE ARGUMENT
ILIST3: POP P,TT
HLRE T,TT
EXCH A,(P)
HRRZ A,(A)
SOJA T,ILIST1 ;Increment count and loop for next element of list.
;FAST MAPC FOR 2 ARGS - CALLED BY LAP CODE ONLY
.MAPC: PUSH P,A
JUMPE B,PRETB
HLRZ A,(B)
HRRZ B,(B)
PUSH P,B
CALLF 1,@-1(P)
POP P,B
JRST .MAPC+1
;FAST MAP FOR 2 ARGS - CALLED BY LAP CODE ONLY
.MAP: PUSH P,A
JUMPE B,PRETB
MOVE A,B
HRRZ B,(B)
PUSH P,B
CALLF 1,@-1(P)
POP P,B
JRST .MAP+1
PRETB: SUB P,[XWD 1,1]
JRST PROG2
; NEW AND SUPER POWERFUL MAP FUNCTIONS
MAPCON: TLZ T,100000 ;MAPLIST, but NCONC the result.
JRST MAPLIST
MAPCAN: TLZA T,100000 ;Pass CAR to func., NCONC the result.
MAPC: TLZA T,400000 ;Pass CAR to func., discard result.
MAPCAR: TLZA T,400000 ;Pass CAR to func., CONS up result.
MAP: TLZ T,200000 ;MAPLIST, but throw away result (returns NIL).
; INITIALIZE
MAPLIST:SETCA T,T ;Good, old-fashioned MAPLIST (returns list of values).
MOVEI A,(<CALLF>) ;...well, not quite. It's now an LSUBR, taking a func.
DPB T,[POINT 4,A,30];of N args. and N lists (N used to be ≡ 1).
MOVE B,P
MOVE AR1,T ;Get N in both halves of AR1.
HRL AR1,T
SUB B,AR1
PUSH P,B ;This is pdl ptr. to func. on stack.
HRLM A,(B) ;Assemble the call on func.
PUSH P,T
PUSH P, ;Init. the result.
HRLZM P,(P) ;(CAR points to current end of result.)
; SET UP TO GET ARGUMENTS
MAPL2: HRRZ T,-1(P) ;No. of args.
MOVEI TT,-3(P) ;Loc. on stack of last arg.
; MOVE ARGS TO REGS
MPL3: MOVE D,(TT)
JUMPE D,MPDN ;Quit if any arg. runs out.
MOVEM D,(T) ;Place in reg. No. of args better be <D !
MOVE D,(D)
SKIPGE -1(P) ;Passing CAR ?
HLRZM D,(T) ;Yes.
HRRZM D,(TT) ;Arg. ← (CDR arg.)
SUBI TT,1
SOJG T,MPL3
XCT (TT) ; CALL THE FUNCTION
LDB C,[POINT 2,-1(P),2] ;Get result code bits.
TRNE C,2
JRST MAPL2 ;Discard result.
; ATTACH TO OUTPUT LIST
SKIPN C ;CONS result ?
PUSHJ P,NCONS ;Yes.
JUMPE A,MAPL2 ;If NCONCing, skip NIL element of result !
HLR B,(P) ;Get ptr. to current end of result...
HRRM A,(B) ;.. and attach new element.
SKIPE C ;If we're NCONCing, set current end of result ptr. to
PUSHJ P,LAST ; end of current element.
HRLM A,(P)
JRST MAPL2
; POP STACK AND RETURN
MPDN: POP P,AR1
MOVE P,-1(P)
POP P,B
SUBS4: HRRZ A,AR1
POPJ P,
;PROG, COND, SETQ, LEXORD
PROG: PUSH P,PA3# ;PA3 saves P during a prog...
PUSH P,PA4# ;PA4 has xwd <start of prog body>,<current loc. in body>
HLRZ TT,(A) ;## TT HAS VARIABLE LIST
HRRZ A,(A) ;## A HAS PROG BODY
HRRM A,PA4
HRLM A,PA4
MOVE T,SP ;$$ADJUST SPDLSAV POINTER TO INCLUDE EVAL BLIP
SUB T,[XWD 2,2] ;$$SO PA3,PA4 CAN BE RESTORED
MOVEM T,SPSV# ;$$BY UNBIND
JRST PG7B ;$$GO CHECK IF ANY VARIABLES TO BIND
PG7A: HLRZ A,(TT)
MOVEI AR1,0
PUSHJ P,BIND
HRRZ TT,(TT)
PG7B: JUMPN TT,PG7A
PUSH SP,SPSV
MOVEM P,PA3
PG1: HRRZ T,PA4
PG1A: JUMPE T,PG4 ;## IF END OF PROG, QUIT
HLRZ A,(T) ;## A HAS FIRST STATEMENT
HRRZ T,(T) ;## T KEEPS THE REST
CAIE A,NIL ;## TEST FOR NIL
CAILE A,INUMIN ;## ALLOW INUMS FOR PROG LABELS 3/28/73
JRST PG1A ;## NOW WE CAN SKIP OVER THIS TYPE OF ATOM
HLLE B,(A) ;## IS IT A ATOM?
AOJE B,PG1A ;## JA, SO JUMP
HRRM T,PA4 ;## SAVE REST OF BODY
PUSH P,SP ;$$SAVE SPDL TO RESTORE AFTER EVAL
PUSHJ P,EVAL ;## EVAL THE STATEMENT
POP P,SP ;$$RESTORE SPDL AFTER EVAL
JRST PG1
PGO: SKIPN PA3 ;## ERROR IF NO PROG
JRST EG2
MOVE P,PA3 ;## BACK UP ON RPDL
MOVE B,1(P) ;## GET FORM
PUSHJ P,UBD
HRLZI C,(<POPJ P,>) ;## NEW CODE TO ALLOW BREAKING
;## AND TRACING OF GO
PUSHJ P,DOSET1 ;##
HLRZ T,PA4
PG5: JUMPE T,EG1 ;## ERROR IF NO TAG FOUND
HLRZ TT,(T) ;## GET THE CAR
HRRZ T,(T) ;## SAVE UP THE REST OF THE BODY
CAIN TT,(A)
JRST PG1A ;FOUND TAG
JRST PG5 ;## TRY AGAIN
RETURN: SKIPN PA3
JRST EG3
MOVE P,PA3
MOVE B,1(P)
PUSHJ P,UBD
HRLZI C,(<POPJ P,>) ;## NEW CODE TO ALLOW BREAKING
;## AND TRACING OF RETURN
PUSHJ P,DOSET1 ;##
JRST PG4+1
PG4: SETZ A,
PUSHJ P,UNBIND
ERRP4: POP P,PA4
POP P,PA3
POPJ P,
GO: HLRZ A,(A)
CAIE A,NIL ;## TEST FOR NIL
CAILE A,INUMIN ;## IS IT AN INUM?(NOW VALID)
JRST PGO ;## SEE IF IT IS THE ONE
HLLE B,(A) ;## IS IT AN ATOM
AOJE B,PGO
PUSHJ P,EVAL
JRST GO+1
SETQ: HLRZ B,(A)
PUSH P,B
PUSHJ P,CADR
PUSHJ P,EVAL
MOVE B,A
POP P,A
SET: SKIPE A ;$$ MUST BE NON-NIL
CAILE A,INUMIN ;$$ AND NOT AN INUM
JRST SETERR ;$$
HLRE AR1,(A) ;$$ AND AN ATOM
AOJN AR1,SETERR ;$$
MOVE AR1,B
PUSHJ P,BIND
SUB SP,[XWD 1,1]
;IFN ML2,{
; SKIPE ML2ROUT
; SUB SP,[XWD 1,1]
; }
MOVE A,AR1
POPJ P,
CON2: HRRZ A,(T)
COND: JUMPE A,CPOPJ ;COND returns NIL if no true antecedents...
PUSH P,A
HLRZ A,(A) ;Get next COND pair.
HLRZ A,(A) ;Get its antecedent.
PUSHJ P,EVAL
POP P,T
JUMPE A,CON2 ;If this antecedent false, go to next pair.
HLRZ T,(T) ;Get the consequent, which is a list of 0 or
HRRZ T,(T) ; more forms. (Returns value of antecedent if
; the consequent is empty).
IPROG: JUMPE T,CPOPJ ;Evaluate a list of forms, returning last value.
IPROGL: HLRZ A,(T) ;Get first form.
HRRZ T,(T) ;
JUMPE T,EVAL ;Save stack space if this is last one.
PUSH P,T
PUSHJ P,EVAL
POP P,T
JRST IPROGL ;Loop for more forms.
;LEXORDER - TRUE IF A IS ALPHAMERICALLY LESS THAT OR EQUAL TO B
LEXORD: MOVE TT,A
PUSHJ P,NUMBERP
JUMPN A,LEX2 ;1ST ARG IS A NUMBER
MOVE A,B
PUSHJ P,NUMBERP
EXCH A,TT
JUMPN TT,FALSE ;1ST←NOT-NUM, 2ND←NUM, DEFINE AS NIL
MOVE T,B
MOVEI B,PNAME(S)
PUSHJ P,GET
EXCH A,T
PUSHJ P,GET
LEX1: JUMPE T,TRUE
JUMPE A,CPOPJ
HLRZ AR1,(A)
MOVE AR1,(AR1)
HLRZ AR2A,(T)
MOVE AR2A,(AR2A)
LSH AR1,-1
LSH AR2A,-1
CAMLE AR1,AR2A
JRST TRUE
CAME AR1,AR2A
JRST FALSE
HRRZ A,(A)
HRRZ T,(T)
JRST LEX1
LEX2: MOVE A,B
PUSHJ P,NUMBERP
EXCH A,TT
JUMPE TT,TRUE ;1ST←NUM, 2ND←NOT-NUM, DEFINE AS TRUE
PUSHJ P,.GREAT ;BOTH NUMBERS, DO (NOT (*GREAT A B))
JRST NOT
PROGN: MOVE T,A ;$$ PROGN
MOVEI A,NIL
JRST IPROG ;$$ IMPLIED PROG DOES THE REST
; ARITHMETIC SUBROUTINES
;macro expander -- (foo a b c) ←> (*foo (*foo a b) c)
EXPAND: MOVE C,B
HRRZ A,(A)
PUSHJ P,REVERSE
JRST EXPA1
EXPN1: MOVE C,B
EXPA1: HRRZ T,(A)
HLRZ A,(A)
JUMPE T,CPOPJ
PUSH P,A
MOVE A,T
PUSHJ P,EXPA1
EXCH A,(P)
PUSHJ P,NCONS
POP P,B
PUSHJ P,XCONS
MOVE B,C
JRST XCONS
PAGE
ADD1: CAILE A,INUMIN
CAIL A,-2
SKIPA B,[INUM0+1]
AOJA A,CPOPJ
.PLUS: JSP C,OP
ADD A,TT
FADR A,TT
SUB1: CAILE A,INUMIN+1
SOJA A,CPOPJ
MOVEI B,INUM0+1
.DIF: JSP C,OP
SUB A,TT
FSBR A,TT
.TIMES: JSP C,OP
IMUL A,TT
FMPR A,TT
.QUO: CAIN B,INUM0
JRST ZERODIV
JSP C,OP
IDIV A,TT
FDVR A,TT
.GREAT: EXCH A,B
JUMPE B,FALSE
.LESS: JUMPE A,CPOPJ
JSP C,OP
JRST COMP2 ;bignums know about me
JRST COMP2
COMP2: CAML A,TT
JRST FALSE
JRST TRUE
.MAX: MOVEI D,.GREAT
SKIPA
.MIN: MOVEI D,.LESS
MOVE AR1,A
MOVE AR2A,B
PUSHJ P,(D)
SKIPN A
MOVE AR1,AR2A
MOVE A,AR1
POPJ P,
MAKNUM:
CAIE B,FLONUM(S) ;## DEFAULT TO FIXNUM, NOT FLONUM
JRST FIX1A
FLO1A: MOVEI B,FLONUM(S)
JRST FLO1A1
FIX1B: SUBI A,INUM0
MOVEI B,FIXNUM(S)
FLO1A1: PUSHJ P,FWCONS
PUSHJ P,XCONS
JRST NUMCNS
NUMVLX: JFCL 17,.+1
NUMVAL: CAIG A,INUMIN
JRST NUMAG1
SUBI A,INUM0
MOVEI B,FIXNUM(S)
POPJ P,
NUMAG1: MOVEM A,AR1
HRRZ A,(A)
HLRZ B,(A)
HRRZ A,(A)
CAIE B,FIXNUM(S)
CAIN B,FLONUM(S)
SKIPA A,(A)
NUMV4: SKIPA A,AR1
POPJ P,
NUMV2: PUSHJ P,EPRINT ;bignums know about me
JRST NONNUM
NUMV3: JRST NONNUM ;bignums change me to JRST BIGDIS
PAGE
FLOAT: IDIVI A,400000
SKIPE A
TLC A,254000
TLC B,233000
FADR A,B
POPJ P,
FIX: PUSH P,A
PUSHJ P,NUMVAL
CAIE B,FLONUM(S)
JRST POPAJ
MULI A,400
TSC A,A
JFCL 17,.+1
ASH B,-243(A)
FIX2: JFCL 10,FIXOV ;bignums change me to jfcl 10,bfix
POP P,A
FIX1: MOVE A,B
JRST FIX1A
MINUSP: PUSHJ P,NUMVAL
JUMPGE A,FALSE
JRST TRUE
MINUS: PUSHJ P,NUMVLX
MOVNS A
JFCL 10,@OPOV
JRST MAKNUM
ABS: PUSHJ P,NUMVLX
MOVMS A
JRST MINUS+2
NUMTYP: PUSHJ P,NUMVAL ;## NUMVAL LEAVES TYPE IN B
MOVEI A,(B) ;## GET THE TYPE
POPJ P,
INUMP: CAIG A,INUMIN ;## INUM IF > INUMIN
JRST FALSE ;## NO, RETURN NIL
POPJ P, ;## RETURN USEFUL VALUE
PAGE
DIVIDE: CAIN B,INUM0
JRST ZERODIV
JSP C,OP
JUMPN RDIV ;bignums know about me
JRST ILLNUM
RDIV: IDIV A,TT
PUSH P,B
PUSHJ P,FIX1A
EXCH A,(P)
PUSHJ P,FIX1A
POP P,B
JRST XCONS
REMAINDER:
PUSHJ P,DIVIDE
JRST CDR
FIXOV: ERR1 [SIXBIT /INTEGER OVERFLOW!/]
ZERODIV:ERR1 [SIXBIT /ZERO DIVISOR!/]
FLOOV: ERR1 [SIXBIT /FLOATING OVERFLOW!/]
ILLNUM: ERR1 [SIXBIT /NON-INTEGRAL OPERAND!/]
GCD: JSP C,OP
JUMPA GCD2 ;bignums know about me
JRST ILLNUM
GCD2: MOVMS A
MOVMS TT
;euclid's algorithm
GCD3: CAMG A,TT
EXCH A,TT
JUMPE TT,FIX1A
IDIV A,TT
MOVE A,B
JRST GCD3
PAGE
;general arithmetic op code routine for mixed types
OP: CAIG A,INUMIN
JRST OPA1
SUBI A,INUM0
CAIG B,INUMIN
JRST OPA2
HRREI TT,-INUM0(B)
XCT (C) ;inum op (cannot cause overflow)
FIX1A: ADDI A,INUM0
CAILE A,INUMIN
CAIL A,-1
JRST FIX1B
POPJ P,
OPA1: HRRZ A,(A)
HLRZ T,(A)
HRRZ A,(A)
CAIE T,FIXNUM(S)
JRST OPA6
SKIPA A,(A)
OPA2:
MOVEI T,FIXNUM(S)
CAILE B,INUMIN
JRST OPB2
HRRZ B,(B)
HRRZ TT,(B)
HLRZ B,(B)
CAIE B,FIXNUM(S)
JRST OPA5
SKIPA TT,(TT)
OPB2: HRREI TT,-INUM0(B)
JFCL 17,.+1
XCT (C) ;fixed pt op
OPOV: JFCL 10,FIXOV ;bignums change this to jfcl 10,fixovl
JRST FIX1A
OPA6: CAILE B,INUMIN
JRST OPB7
HRRZ B,(B)
HRRZ TT,(B)
HLRZ B,(B)
CAIE B,FLONUM(S)
JRST OPB3
CAIE T,FLONUM(S)
JRST NUMV3
MOVE A,(A)
MOVE TT,(TT)
OPR: JFCL 17,.+1
XCT 1(C) ;flt pt op
JFCL 10,FLOOV
JRST FLO1A
OPA5:
CAIE B,FLONUM(S)
JRST NUMV3
PUSHJ P,FLOAT
JRST OPR-1
OPB3:
CAIE B,FIXNUM(S)
JRST NUMV3
SKIPA TT,(TT)
OPB7: HRREI TT,-INUM0(B)
MOVEI B,FIXNUM(S)
CAIE T,FLONUM(S)
JRST NUMV3
MOVE A,(A)
EXCH A,TT
PUSHJ P,FLOAT
EXCH A,TT
JRST OPR
PAGE
SUBTTL EXPLODE, READLIST AND FRIENDS
%FLATSIZEC: SKIPA R,.+1 ;$$ FLATSIZEC - (LENGTH (EXPLODEC))
FLATSIZE: HRRZI R,FLAT2
SETZM FLAT1
PUSHJ P,PRINTA
MOVE A,FLAT1#
JRST FIX1A
FLAT2: AOS FLAT1
POPJ P,
%EXPLODE: SKIPA R,.+1
EXPLODE: HRRZI R,EXPL1
MOVSI AR1,AR1
PUSHJ P,PRINTA
JRST SUBS4
EXPL1: PUSH P,B
PUSH P,C
ANDI A,177
CAIL A,"0"
CAILE A,"9"
JRST EXPL2
ADDI A,INUM0-"0"
JRST EXPL4
EXPL2: PUSH P,AR1
PUSH P,TT
PUSH P,T
LSH A,35
MOVE C,SP
PUSH C,A
MOVEI AR1,1
PUSHJ P,INTER0
POP P,T
POP P,TT
POP P,AR1
EXPL4: PUSHJ P,NCONS
HLR B,AR1
HRRM A,(B)
HRLM A,AR1
POP P,C
JRST POPBJ
PAGE
READLIST:
TDZA T,T
MAKNAM: MOVNI T,1
MOVEM T,NOINFG
JUMPE A,NOLIST
HRRM A,MKNAM3
MOVEI A,MKNAM2
PUSHJ P,READ0
HRRZ T,MKNAM3
CAIE T,-1
JUMPN T,[ERR1 [SIXBIT /MORE THAN ONE S-EXPRESSION-MKNAM!/]]
POPJ P,
MKNAM2: PUSH P,B
PUSH P,T
PUSH P,TT
HRRZ TT,MKNAM3#
JUMPE TT,MKNAM6
CAIN TT,-1
ERR1 [SIXBIT /READ UNHAPPY-MAKNAM!/]
HRRZ B,(TT)
HRRM B,MKNAM3
HLRZ A,(TT)
CAIGE A,INUMIN
JRST MKNAM5
SUBI A,INUM0-"0"
MKNAM4: POP P,TT
POP P,T
JRST POPBJ
MKNAM5: HLRZ A,(TT)
MOVEI B,PNAME(S)
PUSHJ P,GET
HLRZ A,(A)
LDB A,[POINT 7,(A),6]
JRST MKNAM4
MKNAM6: MOVEI A," "
HLLOS MKNAM3
JRST MKNAM4
; A COUPLE OF FUNCTIONS SO THAT THE PROGRAMMER MAY RETURN CELLS TO THE FREE LIST
FREE: MOVEM F,(A) ;$$ RETURN A SINGLE CELL TO FREE LIST
HRRZ F,A
JRST FALSE
FREELI: JUMPE A,CPOPJ ;$$ RETURN A LIST TO THE FREE LIST
HRRZ B,(A)
MOVEM F,(A)
HRRZ F,A
MOVE A,B
JRST FREELI
APPLY.: CAILE A,INUMIN ;$$ AN APPLY TO HANDLE ANY FUNCTION TYPE
JRST UNDTAG
HLRZ T,(A)
CAIE T,-1
JRST GAPP
HRRZ T,(A)
AAGN: JUMPE T,GAPP
HLRZ TT,(T)
HRRZ T,(T)
CAIN TT,FSUBR(S)
JRST [MOVE A,B
HLRZ T,(T)
JRST (T)]
CAIN TT,FEXPR(S)
JRST [ HLRZ T,(T)
HRL T,A
PUSH P,T
MOVE A,B
JRST APPL.2]
CAIN TT,MACRO(S)
JRST [ PUSHJ P,CONS
JRST EVAL]
CAIN TT,EXPR(S)
JRST GAPP
CAIN TT,SUBR(S)
JRST GAPP
CAIE TT,LSUBR(S)
JRST AAGN
GAPP: HRREI T,-2
PUSH P,A
PUSH P,B
JRST APPLY
PAGE
SUBTTL EVAL,APPLY -- THE INTERPRETER
REMOTE<
XXX4:
UBDPTR: UNBOUND
>
EV3: HLRZ A,(AR1)
MOVEI B,VALUE(S)
PUSHJ P,GET
JUMPE A,UNDFUN ;function object has no definition
HRRZ A,(A)
HLRZ B,(AR1) ;$$GET ORIGINAL FN NAME
CAME A,B ;$$IF VALUE IS THE SAME THE WE HAVE A LOOP
CAMN A,UBDPTR
JRST UNDFUN
HRRZ B,(AR1) ;eval (cons (cdr a)(cdr ar1))
PUSHJ P,CONS
JRST XXEVAL
OEVAL: AOJN T,AEVAL
POP P,A
EVAL: PUSH P,SP ;$$SAVE SPDL
PUSHJ P,XXEVAL ;$$GO DO EVALUATION AS USUAL
POP P,SP ;$$RESTORE SPDL
POPJ P, ;$$AND RETURN TO CALLER
XXEVAL: MOVEI AR1,(A)
CAILE A,INUMIN
POPJ P, ;X is small number. See how efficient we are.
HLRZ T,(A) ;Get CAR X
CAIE T,-1
JRST EVAL01 ;X is not an atom.
EE1: MOVE T,(A) ;x is atomic, get its property list.
EV5A: HLRZ TT,(T) ;Look up value of atom. Here's where the
CAIE TT,FLONUM(S)
CAIN TT,FIXNUM(S)
POPJ P,
; CAIE TT,VALUE(S); interpreter spends most of its time !
; JRST EV5
; MOVE T,(T)
; HLRZ T,(T)
; HRRZ A,(T)
JUMPE A,CPOPJ ;NIL
HRRZ A,-1(A) ;VALUE cell now next to atom head. DWP AUG 74
CAIN A,UNBOUND(S)
JRST UNBVAR
POPJ P,
;XEVBIG: MOVE T,(T) ;bignums know about me--NOT ANY MORE ! 3/74
; HRRZ T,(T)
; JUMPN T,EV5A
; JRST UNBVAR
;$$CODE TO PUT EVAL BLIP ON SPECIAL PDL
EVAL01: MOVEI TT,(P) ;$$GET RPDL POINTER
HRLI TT,UNBOUND(S) ;$$ SET UP RPDL POINTER
PUSH SP,TT ;$$ SAVE RPDL POINTER ON SPDL
PUSH SP,A ;$$SAVE EVAL FORM ON SPDL
SKIPE ERINT# ;$$CHECK IF DDT (CONTROL H) INTERRUPT OCCURRED
JRST [ SETZM ERINT# ;$$TURN OFF INTERRUPT FLAG
PUSHJ P,EPRINT ;$$PRINT OUT WHAT WAS INTERRUPTED
ERR1 [SIXBIT /WAS JUST INTERRUPTED - NOW IN ERRORX!/]
]
CAILE T,INUMIN
JRST UNDFUN ;CAR X is a number ?!
HLRO TT,(T)
AOJN TT,EXP3 ;Is car (x) is atomic ?
;CAR of the form is atomic. Look for its function-type properties.
EE2: HRRZ T,(T)
JUMPE T,EV3
HLRZ TT,(T)
HRRZ T,(T)
CAIN TT,SUBR(S)
JRST ESB
CAIN TT,LSUBR(S)
JRST EELS
CAIN TT,EXPR(S)
JRST AEXP
CAIN TT,FSUBR(S)
JRST EFS
CAIN TT,MACRO(S)
JRST EFM
CAIE TT,FEXPR(S)
JRST EE2
HLRZ T,(T)
HLL T,(AR1)
PUSH P,T
HRRZ A,(A)
APPL.2: TLO A,400000
PUSH P,A
MOVNI T,1
JRST IAPPLY
AEXP: HLRZ T,(T)
HLL T,(AR1)
EXP3: PUSH P,T
HRRZ A,(AR1)
CILIST: JSP TT,ILIST
EXP2: JRST IAPPLY
EFS: HLRZ T,(T)
HRRZ A,(AR1)
JRST (T)
ESB: HRRZ A,(AR1)
UUOS2: HLRZ T,(T)
HLL T,(AR1)
PUSH P,T
JSP TT,ILIST
ESB1: CAMGE T,[-NACS]
ERR1 [SIXBIT /TOO MANY ARGS FOR A SUBR !!/]
JRST .+NACS+1(T)
POP P,A+4
POP P,A+3
POP3J: POP P,A+2
POPBAJ: POP P,A+1
POPAJ: POP P,A
POPJ P,
EFM: HLRZ T,(T)
CALLF 1,(T)
JRST EVAL
;HANDLER OF ALISTS AND SPDL CONTEXT POINTERS
ALIST: SKIPE A,-1(P)
PUSHJ P,NUMBERP
MOVEM SP,SPSV
JUMPN A,AEVAL7 ;number
MOVE C,SC2 ;bottom of spec pdl
MOVEM C,AEVAL5#
SETOM AEVAL2
AEVAL8: MOVE C,SP
AEVAL6: CAMN C,AEVAL5 ;bottom spec pdl
JRST AEVAL1 ;done
POP C,T ;pointer for next block
JUMPGE T,AEVAL6 ;$$SKIP ANY EVAL BLIP CRAP
AEVAL4: CAMN C,T
JRST AEVAL6 ;thru with block
POP C,AR1
TLNE AR1,-1 ;$$ TEST FOR EVAL BLIP
JRST .+3
SUB C,[XWD 1,1] ;$$ FOUND ONE, SKIP RPDL WORD
JRST AEVAL4
MOVSS AR1
PUSH SP,(AR1) ;save value cell
HLRM AR1,(AR1) ;store previous value in value cell
HRLM AR1,(SP) ;save pointer to spec pdl loc
JRST AEVAL4
AEVAL: PUSHJ P,ALIST
POP P,A
MOVEI A,UNBIND
EXCH A,(P)
JRST EVAL
AEVAL1: SKIPGE AEVAL2
SKIPN B,-1(P)
JRST ABIND3 ;done with binding
;alist binding
MOVE A,B
PUSHJ P,REVERSE
SKIPA
ABIND2: MOVE A,B
HRRZ B,(A)
HLRZ A,(A)
HRRZ AR1,(A)
HLRZ A,(A)
PUSHJ P,BIND
JUMPN B,ABIND2
ABIND3: PUSH SP,SPSV
POPJ P,
;spec pdl binding
AEVAL7: MOVE A,-1(P)
PUSHJ P,NUMVAL
JUMPL A,.+5 ;MAKE SURE IT IS A VALID STACK POINTER
MOVS T,SC2 ;IT'S NOT, MAKE IT VALID
ADD T,A
ADD A,SC2
HRL A,T
CLEARM AEVAL2#
MOVEM A,AEVAL5 ;point to unbind to
JRST AEVAL8
;AEVAL2: 0 ;0 for number, -1 for a-list
APPLY: MOVEI TT,AP2
CAME T,[-3]
JRST PDLARG
MOVEM T,APFNG1#
PUSHJ P,ALIST
MOVE T,APFNG1
JSP TT,PDLARG
PUSH P,[UNBIND]
AP2: PUSH P,A
MOVEI T,0
AP3: JUMPE B,IAPPLY ;all args pushed; b has arg list
HLRZ C,(B)
PUSH P,C ;push arg
HRRZ B,(B)
SOJA T,AP3
IAP4: JUMPGE D,TOOFEW ;special case for fexprs
AOJN R,TOOFEW
PUSH P,B
MOVE A,SP
PUSHJ P,FIX1A
EXCH A,(P)
MOVE B,A
MOVNI R,2
SOJA T,IAP5
FUNCT: PUSH P,A
MOVE A,SP
PUSHJ P,FIX1A
POP P,B
HLRZ B,(B)
PUSHJ P,XCONS
MOVEI B,FUNARG(S)
JRST XCONS
APFNG: SOS T
MOVEM T,APFNG1
JSP TT,PDLARG ;get args and funarg list
HRRZ A,(A)
HRRZ D,(A) ;a-list pointer
HLRZ A,(A) ;function
HRLZ R,APFNG1 ;no. of args
PUSH P,[UNBIND]
JSP TT,ARGP1 ;replace args and fn name
PUSH P,D ;a-list pointer
PUSHJ P,ALIST ;set up spec pdl
POP P,D
AOS T,APFNG1
;falls in
IAPPLY: MOVE C,T ;state of world at entrance
ADDI C,(P) ;t has - number of args on pdl
ILP1A: HRRZ B,(C) ;next pdl slot has function- poss fun name in lh
CAILE B,INUMIN
JRST UNDTAC
HLRZ A,(B)
CAIN A,-1
JRST IAP1 ;fn is atomic
CAIN A,LAMBDA(S)
JRST IAPLMB
CAIN A,FUNARG(S)
JRST APFNG
CAIN A,LABEL(S)
JRST APLBL
PUSH P,T
MOVE A,B
PUSHJ P,EVAL
POP P,T
MOVE C,T
ADDI C,(P)
ILP1B: MOVEM A,(C)
JRST ILP1A
IAPXPR: HLRZ A,(B)
JRST ILP1B
IAP1: HRRZ B,(B)
JUMPE B,IAP2
HLRZ TT,(B)
HRRZ B,(B)
CAIN TT,EXPR(S)
JRST IAPXPR
CAIN TT,LSUBR(S)
JRST IAP6
CAIE TT,SUBR(S)
JRST IAP1
HLRZ B,(B)
MOVEM B,(C)
JRST ESB1
; APPLY LAMBDA
IAPLMB: HRRZ B,(B)
HLRZ TT,(B) ;Get list of LAMBDA variables.
MOVEM SP,SPSV ;Prepare to mark bindings of vars. on SP.
HRRZ B,(B) ;Get the expression.
HLRZ D,(TT)
CAIN D,-1 ;If the var. list is actually a non-null atom, we
JUMPN TT, IAP3 ; have an LEXPR kluge.
MOVE R,T
IPLMB1: JUMPE T,IPLMB2 ;no more args
JUMPE TT,TOMANY ;too many args supplied
IAP5: HLRZ A,(TT)
MOVEI AR1,1(T)
ADD AR1,P
HLLZ D,(AR1)
HRLM A,(AR1)
HRRZ TT,(TT)
AOJA T,IPLMB1
IPLMB2: JUMPN TT,IAP4 ;too few args supplied
JUMPE R,IAP69
IPLMB4: POP P,AR1
HLRZ A,AR1
AOJG R,IPLMB3
PUSHJ P,BIND
JRST IPLMB4
IPLMB3: SKIPE BACTRF
JRST APBK1
APBK2: MOVEI A,NIL ;$$SETUP FOR IMPLIED PROG
PUSH SP,SPSV
MOVE T,B ;$$SETUP FOR IMPLIED PROG
PUSHJ P,IPROG ;$$INSTEAD OF EVAL
JRST UNBIND
IAP69: POP P,(P)
MOVEI A,NIL ;$$SETUP FOR IMPLIED PROG
MOVE T,B ;$$
JRST IPROG ;$$INSTEAD OF EVAL
APBK1: HRRI AR1,CPOPJ
TLNE AR1,-1
PUSH P,AR1
JRST APBK2
IAP6: MOVEI TT,CPOPJ
MOVEM TT,(C)
HLRZ B,(B)
JRST (B)
APLBL: MOVEM SP,SPSV
HRRZ B,(B)
HLRZ A,(B)
HRRZ B,(B)
HLRZ AR1,(B)
MOVEM AR1,(C)
PUSHJ P,BIND
MOVEI A,APLBL1
EXCH A,-1(C)
EXCH A,LBLAD#
HRLI A,LBLAD
;IFN ML2,{
; SKIPE ML2ROUT
; PUSH SP,[SETZ NIL]
; }
PUSH SP,A
PUSH SP,SPSV
JRST IAPPLY
APLBL1: PUSH P,LBLAD
JRST SPECSTR
IAP2: HRRZ A,(C)
MOVEI B,VALUE(S)
PUSHJ P,GET
JUMPE A,UNDTAC
HRRZ A,(A)
HRRZ B,(C) ;$$GET ORIGINAL FN NAME
CAME A,B ;$$IF THE VALUE IS THE SAME THEN WE HAVE A LOOP
CAIN A,UNBOUND(S)
JRST UNDTAC
JRST ILP1B
IAP3: MOVNI AR1,-INUM0(T) ;lexpr call. Get (positive) no. of args as
MOVE A,TT ; a LISP no., and bind to the atom.
PUSHJ P,BIND
PUSH P,%ARG ;Save old value...
SUBI C,INUM0 ;... and set up %ARG so that (ARG n) and (SETARG n) can
HRRM C,%ARG ; refer to the n'th argument inside this function.
PUSH SP,SPSV ;Mark the binding of the argument count atom.
MOVEI A,NIL ;$$ MORE FOR IMPLIED PROG
MOVE T,B ;$$
PUSHJ P,IPROG ;Evaluate one or more forms, returning last value.
HRRZ T,%ARG
POP P,%ARG ;Restore.
SUBI T,1-INUM0(P) ;Flush the args (and function) from the stack.
HRLI T,-1(T)
ADD P,T
JRST UNBIND
ARG: HRRZ A,@%ARG ;Gets value of args. in an LEXPR.
POPJ P,
SETARG: HRRZM B,@%ARG ;Sets value of args. in an LEXPR.
JRST PROG2
REMOTE<%ARG: XWD A,0>
;;BIND AND UNBIND
REMOTE {
BIND3: XWD 200000,0 ;Bit 1 is to distinguish MLISP2 stack entries.
}
BIND: JUMPE A,BNDERR ;$$CAN'T REBIND NIL
; CAIN A,TRUTH(S) ;$$SHOULDN'T REBIND T ←←←Bullshit.
; JRST BNDERR ;$$
PUSH P,B
HRRM A,BIND3
BIND2:
MOVEI B,VALUE(S) ;bind atom in a to value in ar1,save
PUSHJ P,GET ;old binding on s pdl
JUMPE A,BIND1 ;add value cell
PUSH SP,(A)
IFN ML2,{
SKIPN ML2ROUT
JRST BIND21
PUSH P,A
MOVEI A,1(A) ;Atom head is now next to value cell. DWP AUG 74
PUSHJ P,@SAVE.CONTEXT
POP P,A
}
BIND21: HRLM A,(SP)
HRRM AR1,(A) ;$$THIS WAS HHRZM AR1,(A) WHICH CLOBBERED ATOM POINTER IN MY SYSTEM
POPBJ: POP P,B
POPJ P,
BIND1: ;Add a VALUE cell.
MOVEI B,UNBOUND(S)
MOVEI A,NIL
HRL B,A
MOVE A,BIND3 ;Loc. for VALUE cell has been reserved just before
SUBI A,1 ;atom head (DWP AUG 74)
MOVEM B,(A)
HRRZ B,@BIND3
PUSHJ P,CONS
MOVEI B,VALUE(S)
PUSHJ P,XCONS
HRRM A,@BIND3
MOVE A,BIND3
JRST BIND2
UBD1: SUB SP,[XWD 2,2] ;$$DECREMENT SPDL
UBD: CAMG SP,B ;Unbind SP back to ptr. contained in B.
POPJ P,
HLRZ TT,(SP) ;$$SKIP OVER EVAL BLIPS ETC.
JUMPE TT,UBD1 ;$$IF EQUAL TO 0 IT WAS AN EVAL BLIP
PJUBND: PUSHJ P,UNBIND
JRST UBD ;$$GO BACK AND CHECK
UNBIND:
SPECSTR:MOVE TT,(SP)
CAMN SP,SC2 ;$$CHECK TO AVOID OVERSHOOT
POPJ P, ;$$
SUB SP,[XWD 1,1]
JUMPGE TT,UNBIND ;syncronize stack
UNBND1: CAMN SP,TT
POPJ P,
POP SP,T
CAIN T,(T) ;$$CHECK TO SKIP OVER NEW ITEMS PUT ON SPDL
;$$ALL SUCH ITEMS HAVE 0 LEFT HAND SIDES
JRST PROGUB ;$$THIS IS AN EVAL BLIP - CHECK IF A PROG
MOVSS T
IFN ML2,{
SKIPN ML2ROUT
JRST UNBND8
PUSH P,A
PUSH P,B
MOVEI B,VALUE(S)
MOVEI A,1(T) ;VALUE cell now next to atom header. DWP AUG 74
PUSHJ P,@SAVE.CONTEXT
POP P,B
POP P,A
}
UNBND8: HLRM T,(T) ;$$CHANGED FROM HLRZM T,(T) TO PROTECT NEW ATOM POINTER
JRST UNBND1
PROGUB: HLRZ T,(T) ;$$CHECK FOR A PROG
CAIE T,PROGAT(S) ;$$CHECK IF IT IS A PROG
JRST PROGU1 ;$$NOT A PROG, SKIP IT AND GO ON
MOVE T,(SP) ;$$GET THE RPDL POINTER FOR PROG INTO T
ADDI T,2 ;$$INCREMENT TO GET TO WHERE PA3,PA4 SAVED
POP T,PA4 ;$$RESTORE PA4
POP T,PA3 ;$$AND PA3 FROM WHERE THEY WERE SAVED
PROGU1: POP SP,T ;$$ POP RPDL POINTER
JRST UNBND1 ;$$AND GO ON WITH THE UNBINDING
SPECBIND:
MOVE TT,SP
SPEC1: LDB R,[POINT 13,(T),ACFLD]
CAILE R,17
JRST SPECX
SKIPE R
MOVE R,(R)
IFN ML2,{
SKIPL @(T) ;Is the pointer to the atom or the value cell ?
JRST QUCKBD ;...the cell.
PUSH P,A ;...the atom.
PUSH P,AR1
MOVEI A,@(T)
MOVE AR1,R
PUSHJ P,BIND
POP P,AR1
POP P,A
AOJA T,SPEC1
;QUCKBD: SKIPE ML2ROUT
; PUSH SP,[SETZ NIL]
}
QUCKBD: HLL R,@(T) ;$$AGAIN SAVE THE POOR LITTLE ATOM POINTER
EXCH R,@(T)
HRLI R,@(T)
PUSH SP,R
AOJA T,SPEC1
SPECX: PUSH SP,TT
JRST (T)
REMOTE{ SCANACT: ;This symbol is used by /BREAK1 to see if SCAN is around.
ML2ROUT:
SAVE.CONTEXT: 0
}
IFN ML2,{
ML2SET: MOVEM A,ML2ROUT
MOVEI A,PA3
POPJ P,
}
;random special case compiler run time routines
%AMAKE: PUSH P,A ;make alist for fsubr that requires it
MOVE A,SP
PUSHJ P,FIX1A
MOVE B,A
JRST POPAJ
%UDT: PUSHJ P,PRINT ;error print for undefined computed go tag
STRTIP [SIXBIT /UNDEFINED COMPUTED GO TAG IN !/]
HRRZ R,(P)
PUSHJ P,ERSUB3
JRST ERREND
%LCALL: MOVN A,T ;set up routine for compile lsubr
ADDI A,INUM0
ADDI T,(P)
PUSH P,T
PUSHJ P,(3)
POP P,T
SUBI T,(P)
HRLI T,-1(T)
ADD P,T
POPJ P,
PAGE
SUBTTL ARRAY SUBROUTINES
ARRERR←-1
ARRAY: PUSHJ P,ARRAYS
HRRI AR2A,1(R)
MOVE A,AR2A
PUSH R,[0]
AOBJN A,.-1
ARREND: MOVE A,BPPNR#
MOVEM AR2A,-1(A)
MOVEI A,INUM0+1(R)
MOVEM A,VBPORG(S)
POPJ P,
ARRAYS: PUSH P,A
MOVE A,VBPORG(S)
SUBI A,INUM0
MOVEM A,BPPNR
MOVE A,VBPEND(S)
MOVNI A,-INUM0-2(A)
ADD A,BPPNR ;bporg-bpend+2
HRLM A,BPPNR
POP P,A
HRRZ AR1,(A) ;(cdr l)
HLRZ A,(A) ;(car l)name
HRRZ B,BPPNR
ADDI B,2
MOVEI C,SUBR(S)
PUSHJ P,PUTPROP
HLRZ A,(AR1) ;(cadr l)mode
PUSH P,AR1
PUSHJ P,EVAL ;eval mode
POP P,AR1
MOVEM A,AMODE#
MOVEI C,44
JUMPE A,ARRY1
MOVEI C,-INUM0(A)
CAILE A,INUMIN
JRST ARRY1
MOVEI C,22
HRRZ A,BPPNR
MOVE B,GCMKL
PUSHJ P,CONS
MOVEM A,GCMKL
ARRY1: MOVEM C,BSIZE#
MOVEI A,44
IDIV A,C
MOVEM A,NBYTES#
HRRZ A,(AR1) ;(cddr l)bound pair list
JSP TT,ILIST
AOS R,BPPNR
MOVEI AR1,1 ;ar1 is array size
MOVEI AR2A,0 ;ar2a is cumulative residue
AOJGE T,ARRYS ;single dimension
MOVEI D,A-1
SUB D,T ;d is next ac for array code generation
ARRY2: PUSHJ P,ARRB0
TLC TT,(<IMULI>)
DPB D,[POINT 4,TT,ACFLD]
PUSH R,TT
CAIN D,A
JRST ARRY3
MOVSI TT,(<ADD>)
ADDI TT,1(D)
DPB D,[POINT 4,TT,ACFLD]
PUSH R,TT
SOJA D,ARRY2
ARRB0: POP P,TT
EXCH TT,(P)
CAILE TT,INUMIN
JRST ARRB1
HLRZ A,(TT)
HRRZ TT,(TT)
SUBI TT,(A)
ADDI TT,1
JRST ARRB2
ARRB1: MOVEI A,INUM0
SUB TT,A
ARRB2: IMUL A,AR1
IMULB AR1,TT
ADDM A,AR2A
POPJ P,
ARRY3: PUSH R,[ADD A,B]
ARRYS: PUSHJ P,ARRB0
HRRZ TT,BPPNR
MOVEM AR2A,(TT)
HRLI TT,(<SUB A,>)
PUSH R,TT
PUSH R,[JUMPL A,ARRERR]
MOVE TT,AR1
HRLI TT,(<CAIL A,>)
PUSH R,TT
PUSH R,[JRST ARRERR]
IDIV AR1,NBYTES ;calc #words in array
SKIPE AR2A ;correct for remainder non-zero
ADDI AR1,1
MOVE TT,NBYTES
SOJE TT,ARRY6
ADDI TT,1
HRLI TT,(<IDIVI A,>)
PUSH R,TT
MOVN TT,BSIZE
LSH TT,14
HRLI TT,(<IMULI B,>)
PUSH R,TT
MOVEI TT,44+200
SUB TT,BSIZE
LSH TT,6
ARRY6: ADD TT,BSIZE
LSH TT,6
SKIPE AR2A,AMODE
CAIL AR2A,INUMIN
ADDI TT,40 ;mode not ← t
TLC TT,(<HRLZI C,>)
PUSH R,TT
MOVEI TT,4(R)
HRLI TT,(<ADDI C,(A)>)
PUSH R,TT
PUSH R,[LDB A,C]
HRLZI AR2A,(<POPJ P,>)
SKIPN TT,AMODE
MOVE AR2A,[JRST FLO1A]
CAIL TT,INUMIN
MOVE AR2A,[JRST FIX1A]
PUSH R,AR2A
MOVS AR2A,AR1
MOVNS AR2A
POPJ P,
PAGE
GTBLK: MOVNI C,-INUM0(A) ;##COMPUTE NEGATIVE LENGTH
MOVE A,VBPORG(S) ;## GET BPORG
HRRI A,-INUM0(A) ;## CONVERT
HRLM C,(A) ;## MOVE TO BPORG INFO FOR (GC)
HRRM A,(A) ;##
AOS R,(A) ;## ADD ONE TO INFO AND MOVE TO R
SUBI R,1 ;## SET PUSH DOWN POINTER(ASSUME POINTER BLOCK)
CAIN B,0 ;## IS IT A POINTER BLOCK?
SUBI R,1 ;## NO
MOVE AR1,VBPEND(S) ;## GET BPEND
MOVNI AR1,-INUM0(AR1) ;## CONVERT TO NEGATIVE
ADD AR1,R ;## BPORG-BPEND +(0 OR 1)
HRLI R,(AR1) ;## MOVE TO R FOR TESTING FOR BPS EXCEEDED
PUSH R,[0] ;## CLEAR THE SPACE, NOTE THAT IF IT IS NOT
AOJN C,.-1 ;## WE WILL ALSO CLEAR THE INFO LOCATION
HRRZI R,INUM0+1(R) ;## COMPUTE NEW BPORG
HRRM R,VBPORG(S)
CAIN B,0 ;## IF IT WAS NOT A POINTER BLOCK, DONE
POPJ P,
MOVE B,GCMKL ;## GET GC'S LIST
PUSHJ P,CONS ;## CONS
MOVEM A,GCMKL ;## SAVE IT
HLRZ A,(A) ;GET THE OLD BPORG BACK
AOJA A,.-5 ;## ADD ONE AND RETURN
BLKLST: PUSH P,A ;## SAVE LIST
CAIE B,0 ;## BLK LENGTH GIVEN
SKIPA A,B ;## YES
PUSHJ P,LENGTH ;## NO, USE LENGTH OF LIST
MOVEI B,(A) ;## GET A POINTER BLOCK FROM GTBLK
PUSHJ P,GTBLK
POP P,B ;## GET LIST BACK
PUSH P,A
HRRZI R,-1(A) ;## SET UP PDL
HLRE C,(R) ;## NEG LENGTH FROM GC INFO.
BLKLS1: HRRI A,1(A) ;## BUMP A FOR CDR
IFN OLDNIL< ;## IF(CDR NIL)#NIL
TRNE B,-1 ;## END OF LIST?
SKIPA B,(B) ;## NO
SETZ B, ;## YES, REST OF BLOCK IS NIL
>
IFE OLDNIL<
MOVE B,(B) ;## IF (CDR NIL )←NIL
>
HLL A,B ;## GET (CAR LIST)
PUSH R,A ;## AND STORE
AOJL C,BLKLS1 ;## SEE IF DONE
HLLZM A,(R) ;## SET (CDR (LAST BLOCK)) TO NIL
JRST POPAJ ;## AND RETURN POINTER TO THE BLOCK
EXARRAY: PUSH P,A
HLRZ A,(A)
PUSHJ P,GETSYM
JUMPE A,POPAJ
PUSHJ P,NUMVAL
EXCH A,(P)
PUSHJ P,ARRAYS
POP P,A
HRRM A,-2(R)
HRR AR2A,A
JRST ARREND
STORE: PUSH P,A
PUSHJ P,CADR
PUSHJ P,EVAL ;value to store
EXCH A,(P)
HLRZ A,(A)
PUSHJ P,EVAL ;byte pointer returned in c
POP P,A
NSTR: PUSH P,A
TLNE C,40
PUSHJ P,NUMVAL ;numerical array
DPB A,C
POP P,A
POPJ P,
PAGE
SUBTTL EXAMINE, DEPOSIT , ETC
BOOLE: MOVE TT,T
ADDI TT,2(P)
MOVE A,-1(TT)
SUBI A,INUM0
DPB A,[POINT 4,BOOLI,OPFLD-2]
PUSHJ P,BOOLG
MOVE C,A
BOOLL: PUSHJ P,BOOLG
XCT BOOLI
JRST BOOLL
REMOTE<
BOOLI: CLEARB C,A>
BOOLG: CAIL TT,(P)
JRST BOOL1
MOVE A,(TT)
PUSHJ P,NUMVAL
AOJA TT,CPOPJ
BOOL1: HRLI T,-1(T)
ADD P,T
POP P,B
JRST FIX1A
EXAMINE:PUSHJ P,NUMVAL
MOVE A,(A)
JRST FIX1A
DEPOSIT:MOVE C,B
PUSHJ P,NUMVAL
EXCH A,C
PUSHJ P,NUMVAL
MOVEM A,(C)
JRST MAKNUM
LSH: MOVEI C,-INUM0(B)
PUSHJ P,NUMVAL
LSH A,(C)
JRST FIX1A
PAGE
; GC -- GARBAGE COLLECTOR - Marking phase.
GC: POLL ; SAIL reschedule pending?
PUSHJ P,AGC ;Collect garbage.
JRST FALSE
AGC: SETOM GCFLG ;SET GCFLAG IN CASE OF USER CONTROL-C
MOVEM R,RGC#
GCPK1: PUSH P,PA3 ;Now we place in the pdl all things that might
PUSH P,PA4 ; point into free storage, so that we can mark them.
IFE OLDNIL <PUSH P,NILPRP ;## PROP LIST OF NIL>
PUSH P,UBDPTR ;special atom UNBOUND; not on OBLIST
PUSH P,MKNAM3
PUSH P,GCMKL ;i/o channel input lists and arrays
PUSH P,BIND3
PUSH P,INITF
PUSH P,INITF1 ;## INIT FILE LIST
PUSH P,TSV ;For UUOH
PUSH P,TTSV ; " "
GCPK2: ;This marks the end of the things we push....
HRRZ S,GCP4 ;Bottom of reg pdl+1; place to put marked ac's for marking
MOVEI R,LSTMAC(S)
BLT S,(R) ;save ACs 0 through LSTMAC at bottom of regpdl
JRST GCP2
REMOTE<
GCP2: SETZB 0,X ;gc indicator, init. for bit table zero
MOVE A,C3GC
GCP5: BLT A,X ;zero bit tables.(.←top of bit tables)
JRST GCRET1
>
GCRET1: SKIPN GCGAGV
JRST GCP5A
SKIPN F
STRTIP [SIXBIT /←FREE STG EXHAUSTED←!/]
SKIPN FF
STRTIP [SIXBIT /←FULL WORD SPACE EXHAUSTED←!/]
GCP5A: MOVEI TT,-1 ;Magic bits for MRKLST !
MOVEI A,0
CALLI A,STIME ;time
MOVNS A
ADDM A,GCTIM#
MOVE S,ATMOV ;S must contain its usual thing for MRKLST.
;;Now we mark the reg. pdl...
MOVE C,GCP3# ;GCP3 points to real bottom of reg pdl (containing ptr. to
MOVE R,P ; the OBLIST).
PUSHJ P,MRKPDL
HRRZ C,SC2 ;Now mark the spec, pdl.
MOVE R,SP
PUSHJ P,MRKPDL
HRRZ R,GCMKL ;mark arrays
GCP6D: JUMPE R,GCSWP ;No more arrays. Go to sweep phase.
HLRZ A,(R)
MOVE D,(A)
GCP6E: HLRZ A,(D) ;Mark left half of array entry...
PUSHJ P,MRKLST
HRRZ A,(D) ;Mark right half of array entry...
PUSHJ P,MRKLST
AOBJN D,GCP6E ;Next entry of array.
HRRZ R,(R) ;Next array.
JRST GCP6D
MRKPDL: MOVEI B,0 ;Mark everything in a pdl.
SUBM C,R ;Get no. of items in the pdl.
HRLI C,-1(R)
JUMPGE C,CPOPJ
GC1: HRRZ A,(C)
PUSHJ P,MRKLST ;Mark next thing in pdl.
AOBJN C,GC1 ;Try for more.
POPJ P,
MRKLS2: HLRZ F,F ;Get CADR of the item we just marked.
CAIE F,FIXNUM(S);Is it a number ?
CAIN F,FLONUM(S)
POPJ P, ;Yes. (This POPJ will get us to MRKLS1 to mark its CDR.)
SOSA A,AR2A ;A real atom. Mark its (possible) VALUE cell. (DWP AUG 74)
MRKLS1: HLRZ A,1(P) ;Get saved CDR of last item and mark it...
;MRKLST marks all the elements in one s-expression.
MRKLST: CAMGE A,FWSTOP ;Top of full word space.
CAMGE A,FSBOT ;Bottom of FS.
POPJ P, ;Item is not a pointer into FS or FWS.
CAML A,FSTOP ;FSTOP points to first loc. of full word space (FWS).
JRST GCMFW ;Item is in FWS.
MOVE AR2A,A ;Copy item (for MRKLS2).
MOVS F,(A) ;Get the S-expression.
LSHC A,-5 ;Calc. (address MOD 32.) of the S-expression.
ROT B,5
MOVE AR1,GCBT(B);Pick up a bit in corresponding position...
TDOE AR1,@GCBTP ;Get proper word from bit table.
POPJ P, ;This s-expression is already marked, so quit.
MOVEM AR1,@GCBTP;Mark it.
HRRZ A,F ;Now to mark its CAR and CDR.
HRRI F,MRKLS1 ;Fake up a PUSHJ...
PUSH P,F ;Set return addr. to MRKLS1 and save CDR of our s-expr...
CAIN A,-1 ;... is our s-expr an atom ?
JRA F,MRKLS2 ;Either an atom or a number. Pick up its CDR.
JRST MRKLST ;No. Go mark its CAR and CDR.
GCMFW: MOVEI AR1,@GCMFWS ;Get relative address in FWS of item.
IDIVI AR1,44 ;Make a byte ptr. to bit in bit table for this
MOVNS AR2A ; address in FWS...
LSH AR2A,36
ADD AR2A,C2GC
DPB TT,AR2A ;Turn on mark bit. (TT contains 0,,-1.)
POPJ P,
REMOTE { ;Table of pointers (set up by INALLC) to various storage boundaries:
FSBOT: FS ;current bottom of free storage
FSTOP: X ;Top of free stg., bottom of FWS.
FWSTOP: X ;Top of FWS, bottom of bit tables.
SFS: X ;Size of free stg.
SFWS: X ;Size of full word stg.
SBT: X ;Size of bit tables.
SBPS: X ;Size of binary program space. (= contents of S !!)
GCBTP: JFCL X(A) ;bit tab-(fs-5)
GCMFWS: JFCL X(A) ;-FSTOP, i.e., -(first addr. of FWS).
C2GC: POINT 1,X(AR1),0;(XWD 430100+AR1,X) ;bottom of fws bit table
C3GC: X ;bottom bit table,,bottom bit table+1
C1GCS: X ;- length of fws,,bottom of fws
C2GCS: XWD 100,X ;bottom of fws bit table
C3GCS: X ;-n wds in bt,,bt
GCMKL: [XWD [XWD -NIOCH,CHTAB+FSTCH],0] ;A list of all arrays in system. Format
;is ( ... (-length.firstaddress) ... ). CHTAB is treated as an array.
}
GCBT: XWD 400000,0 ;Table of bits in positions 0-31 of a word.
ZZ←←1B1
XLIST
REPEAT =31,<ZZ
ZZ←←ZZ/2>
LIST
; GC Sweep phase.
GCSWP: MOVSI R,GFSWPP
BLT R,LPROG
MOVEI F,NIL
MOVE D,C3GCS
MOVEI REL,0 ;Length of free stg. list...
JRST XXX3
GFSPR: MOVEM REL,FSFREE# ;Record amount of free stg...
MOVE REL,CONSVAL# ;... and also current value of CONS counter.
MOVEM REL,OCONSV#
MOVE A,C1GCS
MOVE B,C2GCS
PUSHJ P,GCS0
SKIPN GCGAGV
JRST GCSPI1
MOVE B,F
PUSHJ P,GCPNT
STRTIP [SIXBIT / FREE STG,!/]
MOVE B,FF
PUSHJ P,GCPNT
STRTIP [SIXBIT / FULL WORDS AVAILABLE←!/]
GCSPI1: HRLZ S,GCP4 ;bottom of reg pdl+1
BLT S,LSTMAC ;reload marked ac's
SUB P,[XWD GCPK2-GCPK1,GCPK2-GCPK1] ;restore p
JUMPE F,[ERR2 [SIXBIT /NO FREE STG LEFT!/]]
JUMPE FF,[ERR2 [SIXBIT /NO FW STG LEFT!/]]
MOVE R,RGC
MOVEI S,0
CALLI S,STIME ;time
ADDM S,GCTIM
MOVE S,ATMOV ;$$RESTORE ATOM OFFSET RELOCATOR (FOOLIST)
;$$HOPEFULLY S IS USED ONLY BY GC AND ATOM RELOCATION
AOSN GCFLG ;CHECK FLAG FOR PENDING INTERRUPT
POPJ P, ;NO- SO NORMAL EXIT
POP P,JOBOPC ;INTERRUPT WILL CONTINUE FROM THE GC RETURN
PUSH P,GCFLG ;GC WILL RETURN TO THE INTERRUPT POINT
SETZM GCFLG ;CLEAR GCFLG
SOS (P) ;Compensate for the AOSN above.
POPJ P,
GFSWPP: ;Here is the sweeping code, which runs in the AC's.
PHASE 0
GFSP1←←.
JUMPL S,GFSP2
HRRZM F,(R)
HRRZ F,R
ADDI REL,1
GFSP2←←.
ROT S,1
AOBJN R,GFSP1
JRST [ MOVE S,(D)
HRLI R,-40
AOBJN D,GFSP1
JRST GFSPR]
LPROG←←.-1
DEPHASE
REMOTE {
XXX3: MOVEI R,FS ;$$ANOTHER FOOLIST REMNANT
GCBTL1: HRLI R,X ;-(32-<fs&37>
MOVE S,(D)
GCBTL2: ROT S,X ;fs&37
AOBJN D,GFSP1
JRST GFSPR
}
GCS0: MOVEI FF,0 ;Sweeping code for FWS.
GCS1: ILDB C,B
JUMPN C,GCS2
HRRZM FF,(A)
HRRZ FF,A
GCS2: AOBJN A,GCS1
POPJ P,
GCGAG: EXCH A,GCGAGV#
POPJ P,
SPEAK: SKIPA A,CONSVAL ;Return total no. of CONSes done.
GCTIME: MOVE A,GCTIM ;Return total time spent garbage collecting.
JRST FIX1A
TIME: MOVEI A,0
CALLI A,STIME
JRST FIX1A
FSAVAI: MOVE A,OCONSV ;Calculate amount of free stg. available.
SUB A,CONSVAL
ADD A,FSFREE
JRST FIX1A
GCPNT: MOVEI R,TTYO
MOVEI A,0
JUMPE B,PRINL1
HRRZ B,(B)
AOJA A,.-2
GCING: OUTSTR [ASCIZ /
GARBAGE COLLECTING
/]
POP P,GCFLG ;CAN'T INTERRUPT GC, QUEUE UP THE REQUEST
JRST @JOBOPC
PAGE
SUBTTL SYMBOL TABLE ACCESSING ROUTINES AND DDT INTERFACE
R50MAK: PUSHJ P,PNAMUK
PUSH C,[0]
HRLI C,700
HRRI C,(SP)
MOVEI B,0
MK3: ILDB A,C
JUMPE A,CPOPJ
LDB A,R50FLD
SKIPN A
MOVEI A,46 ;Make all non-radix50 chars. into $.
IMULI B,50
ADD B,A
CAMGE B,[50*50*50*50*50]
JRST MK3
POPJ P,
;## NEW ROUTINES FOR CONVERTING SYMBOLS TO CONS CELL
SYMERR: MOVE A,B
SYMER1: PUSHJ P,EPRINT ;## PRINT OFFENDER
ERR1 [SIXBIT /NOT A CONS CELL !/]
;## **CAUSES ERROR IF NOT IN FREE STORAGE**
RGTSYM: PUSHJ P,GETSYM
PUSHJ P,NUMVAL ;## CONVERT TO REAL ADDRESS
ADDI A,(S) ;## ADD RELOCATION
CAIL A,FS(S) ;## LESS THAN FS(S) IS NOT CONS CELL
CAML A,FWSO ;## FS(S)<← A < FWSO IS A CONS CELL
JRST SYMER1
POPJ P,
GETSYM: PUSHJ P,R50MAK
TLO B,040000 ;04 for globals
MOVE C,JOBSYM
MK7: CAMN B,(C)
JRST MK10 ;found
AOBJP C,.+2
AOBJN C,MK7
TLC B,140000 ;10 for locals
TLNE B,100000
JRST MK7-1
JRST FALSE
MK10: MOVE A,1(C) ;value
JRST FIX1A
;## ROUTINE TO STORE A CONS CELL SO THAT IT CAN BE
;## REFERENCED VIA ,CELL(S) I.E. THRU INDEX REG. S
;## ERROR IF NOT LEGITIMATE CONS CELL
RPTSYM: CAIL B,FS(S) ;## FS(S) ←< B <FWSO IS A LEGIT
CAML B,FWSO ;## CONS CELL, ALL ELSE IS ERROR
JRST SYMERR ;## ERROR
SUBI B,(S) ;## STRIP OF RELOCATION
PUTSYM: PUSH P,B
PUSHJ P,R50MAK
MOVEI A,2
MOVEI D,0
PUSHJ P,MORCOR ;Be sure we have room.
MOVEM A,CORUSE ;We are using from top, not bottom.
TLO B,040000 ;make global
SKIPL JOBSYM
AOS JOBSYM ;increment initial symbol table pointer
MOVN A,[XWD 2,2]
ADDB A,JOBSYM
MOVEM B,(A) ;name
POP P,1(A) ;value
JRST FALSE
DDTLOD: PTYUUO 15,[0↔[ASCIZ ⊗SYS:RAID
/G
(SETDDT(CAR(GETSYM SUBR DDT)))
⊗]]
JRST LOAD
DDTSET: PUSHJ P,NUMVAL
SETDDT A,
POPJ P,
PATCH: BLOCK 40
SUBTTL SPRINT -- THE PRETTY PRINTER
;THIS IS THE NEW IMPROVED VERSION OF SPRINT
; 0(P) ← A
; -1(P) ← B
; -2(P) ← C
; -3(P) ← M
; -4(P) ← N
; -5(P) ← X
SPRINT: SUBI B,INUM0
SPRNT2: PUSH P,A
PUSH P,B
SETZM M#
SETZM CSW#
MOVEM P,STP#
MOVEI B,0
PUSHJ P,DEPTH
SKIPN B,M
JRST .+6
MOVE A,LINL
SUB A,B
SUB A,B
IDIV A,B
CAILE A,14
MOVEI A,14
MOVEM A,CUT#
MOVE A,0(P)
IDIV A,LINL
CAIG B,0
ADD B,LINL
MOVEM B,0(P)
MOVEI C,0
JRST .+3
ISPRIN: PUSH P,A
PUSH P,B
PUSH P,C
PUSH P,[0]
PUSH P,[0]
PUSH P,[0]
MOVE A,B
SUB B,LINL
JUMPLE B,.+3
MOVE A,B
MOVEM A,-4(P)
PUSHJ P,POS
MOVE A,-5(P)
PUSHJ P,PATOM
JUMPE A,.+4
SPRN1: MOVE A,-5(P)
PUSHJ P,PRIN1
JRST SPRN22
MOVE B,LINL
SUB B,-4(P)
ADDI B,1
MOVEM B,0(P)
SUB B,-3(P)
MOVE A,-5(P)
PUSHJ P,FLATLE
JUMPN A,SPRN1
MOVEI A,50
PUSHJ P,TYO
AOS -4(P)
SOS 0(P)
HRRZ A,@-5(P)
PUSHJ P,PATOM
JUMPN A,SPRN13
HLRZ A,@-5(P)
CAIN A,LAMBDA(S)
JRST LAM
CAIN A,PROGAT(S)
JRST PRG
PUSHJ P,PATOM
JUMPE A,SPRN3
HLRZ A,@-5(P)
PUSHJ P,PRIN1
MOVE A,0(P)
SUB A,CHCT
MOVEM A,-1(P)
CAIG A,24
JRST SPRN4
JRST SPRN12+4
SPRN3: MOVE B,0(P)
CAILE B,20
MOVEI B,20
HLRZ A,@-5(P)
PUSHJ P,FLATLE
JUMPE A,SPRN12
MOVEM A,-1(P)
SPRN4: HRRZ A,@-5(P)
MOVEM A,-2(P)
HRRZ A,0(A)
PUSHJ P,PATOM
JUMPN A,SPRN8
MOVE B,-1(P)
CAMG B,CUT
JRST SPRN2
SKIPE CSW
JRST SPRN8
MOVE A,0(P)
SUB A,B
SUBI A,1
MOVEM A,-1(P)
JRST SPRN5
SPRN2: HLRZ A,@-5(P)
PUSHJ P,PATOM
JUMPN A,.+3
HLRZ A,@-5(P)
PUSHJ P,PRIN1
HRRZ A,@-5(P)
MOVEM A,-5(P)
MOVE A,-4(P)
ADD A,-1(P)
ADDI A,1
MOVEM A,-4(P)
JRST SPRN12
SPRN5: MOVE B,-1(P)
HLRZ A,@-2(P)
PUSHJ P,FLATLE
JUMPE A,SPRN8
HRRZ A,@-2(P)
MOVEM A,-2(P)
HRRZ A,0(A)
PUSHJ P,PATOM
JUMPE A,SPRN5
HRRZ B,@-2(P)
JUMPN B,.+3
MOVE B,-1(P)
SOJA B,SPRN7
HRRZ A,@-2(P)
PUSHJ P,FLATSI
SUBI A,INUM0-4
SUB A,-1(P)
MOVN B,A
SPRN7: SUB B,-3(P)
HLRZ A,@-2(P)
PUSHJ P,FLATLE
JUMPN A,SPRN18
SPRN8: HLRZ A,@-5(P)
PUSHJ P,PATOM
JUMPN A,.+3
SPRN9: HLRZ A,@-5(P)
PUSHJ P,PRIN1
HRRZ A,@-5(P)
MOVEM A,-5(P)
CAMN A,-2(P)
JRST SPRN11
MOVE A,-4(P)
PUSHJ P,POS
JRST SPRN9
SPRN11: HRRZ A,@-5(P)
PUSHJ P,PATOM
JUMPN A,SPRN13
SPRN12: MOVEI C,0
MOVE B,-4(P)
HLRZ A,@-5(P)
PUSHJ P,ISPRIN
HRRZ A,@-5(P)
MOVEM A,-5(P)
JRST SPRN11
SPRN13: HRRZ A,@-5(P)
JUMPE A,.+4
PUSHJ P,FLATSI
SUBI A,INUM0-3
ADDM A,-3(P)
AOS -3(P)
MOVE C,-3(P)
MOVE B,-4(P)
HLRZ A,@-5(P)
PUSHJ P,ISPRIN
SPRN16: HRRZ A,@-5(P)
JUMPE A,SPRN17
MOVEI A,40
PUSHJ P,TYO
MOVEI A,56
PUSHJ P,TYO
MOVEI A,40
PUSHJ P,TYO
HRRZ A,@-5(P)
PUSHJ P,PRIN1
SPRN17: MOVEI A,51
PUSHJ P,TYO
JRST SPRN22
SPRN18: HLRZ A,@-5(P)
PUSHJ P,PATOM
JUMPN A,.+3
HLRZ A,@-5(P)
PUSHJ P,PRIN1
MOVEI A,40
PUSHJ P,TYO
HRRZ A,@-5(P)
MOVEM A,-5(P)
MOVE A,LINL
SUB A,CHCT
ADDI A,1
MOVEM A,-4(P)
HRRZ A,@-5(P)
PUSHJ P,PATOM
JUMPN A,SPRN21
SPRN19: HLRZ A,@-5(P)
PUSHJ P,PRIN1
HRRZ A,@-5(P)
MOVEM A,-5(P)
HRRZ A,0(A)
PUSHJ P,PATOM
JUMPN A,.+4
MOVE A,-4(P)
PUSHJ P,POS
JRST SPRN19
MOVE A,-4(P)
PUSHJ P,POS
SPRN21: HLRZ A,@-5(P)
PUSHJ P,PRIN1
JRST SPRN16
LAM: PUSHJ P,PRIN1
HRRZ A,@-5(P)
MOVEM A,-5(P)
MOVE B,-4(P)
MOVEM B,-1(P)
HLRZ A,0(A)
PUSHJ P,PATOM
MOVEI B,6
CAIE A,NIL
ADDI B,1
ADDM B,-4(P)
HRRZ A,@-5(P)
PUSHJ P,PATOM
JUMPN A,SPRN13
MOVEI C,0
MOVE B,-4(P)
HLRZ A,@-5(P)
PUSHJ P,ISPRIN
MOVE B,-1(P)
MOVEM B,-4(P)
JRST SPRN12+4
PRG: PUSHJ P,PRIN1
HRRZ A,@-5(P)
MOVEM A,-5(P)
MOVE A,-4(P)
MOVEM A,-1(P)
MOVEI A,5
ADDM A,-4(P)
HRRZ A,@-5(P)
PUSHJ P,PATOM
JUMPN A,SPRN13
MOVEI C,0
MOVE B,-4(P)
HLRZ A,@-5(P)
PUSHJ P,ISPRIN
MOVE A,0(P)
SUBI A,5
MOVEM A,-2(P)
PRG1: HRRZ A,@-5(P)
MOVEM A,-5(P)
HRRZ A,0(A)
PUSHJ P,PATOM
JUMPN A,PRG3
HLRZ A,@-5(P)
PUSHJ P,PATOM
JUMPE A,PRG2
MOVE A,-1(P)
PUSHJ P,POS
HLRZ A,@-5(P)
PUSHJ P,PRIN1
JRST PRG1
PRG2: MOVE A,CHCT
CAMG A,-2(P)
PUSHJ P,TERPRI
MOVEI C,0
MOVE B,-4(P)
HLRZ A,@-5(P)
PUSHJ P,ISPRIN
JRST PRG1
PRG3: HLRZ A,@-5(P)
PUSHJ P,PATOM
JUMPE A,SPRN13
MOVE B,-1(P)
MOVEM B,-4(P)
JRST SPRN13
SPRN22: MOVEI A,NIL
SUB P,[XWD 6,6]
POPJ P,
POS: PUSH P,A
PUSH P,[0]
MOVE A,LINL
SUB A,CHCT
ADDI A,1
PUSH P,A
CAMN A,-2(P)
JRST POS4
CAMG A,-2(P)
JRST .+4
PUSHJ P,TERPRI
MOVEI A,1
MOVEM A,0(P)
SUBI A,1
LSH A,-3
ADDI A,1
LSH A,3
ADDI A,1
MOVEM A,-1(P)
CAMLE A,-2(P)
JRST POS3
POS2: MOVEI A,11
PUSHJ P,TYO
MOVE A,-1(P)
MOVEM A,0(P)
ADDI A,10
JRST POS2-3
POS3: AOS A,0(P)
CAMLE A,-2(P)
JRST POS4
MOVEI A,40
PUSHJ P,TYO
JRST POS3
POS4: SUB P,[XWD 3,3]
POPJ P,
FLATLE: JUMPLE B,ABORT+1
SETZM M
MOVEM B,N#
MOVEM P,STP
SCAN: PUSH P,A
PUSHJ P,PATOM
JUMPN A,EXIT1-6
NA: AOS A,M
CAMLE A,N
JRST ABORT
HLRZ A,@0(P)
PUSHJ P,SCAN
HRRZ A,@0(P)
MOVEM A,0(P)
JUMPN A,.+3
AOS A,M
JRST EXIT1-2
MOVE A,0(P)
PUSHJ P,PATOM
JUMPE A,NA
MOVEI A,4
ADDB A,M
CAMLE A,N
JRST ABORT
MOVE A,0(P)
PUSHJ P,FLATSI
SUBI A,INUM0
ADDB A,M
CAMLE A,N
JRST ABORT
EXIT1: SUB P,[XWD 1,1]
POPJ P,
ABORT: MOVE P,STP
MOVEI A,NIL
POPJ P,
DEPTH: PUSH P,A
PUSH P,B
PUSHJ P,PATOM
JUMPN A,D2
AOS A,0(P)
CAMLE A,LINL
JRST OUT+1
CAMLE A,M
MOVEM A,M
MOVE A,-1(P)
PUSH P,A
PUSH P,[0]
D1: HLRZ A,@-3(P)
MOVE B,-2(P)
PUSHJ P,DEPTH
HRRZ A,@-3(P)
MOVEM A,-3(P)
MOVE B,-1(P)
SETCMB C,0(P)
JUMPN C,.+3
HRRZ B,0(B)
MOVEM B,-1(P)
CAMN A,B
JRST OUT
PUSHJ P,PATOM
JUMPE A,D1
SUB P,[XWD 2,2]
D2: SUB P,[XWD 2,2]
POPJ P,
OUT: SETOM CSW
MOVE P,STP
JRST @1(P)
;
;
;(TAB X) TABS TO POSITION X DOING A (TERPRI) IF NECESSARY
;
.TAB: PUSHJ P,NUMVAL
PUSHJ P,POS ;LET POS IN SPRINT DO THE WORK
JRST FALSE
SUBTTL SAIL-LISP INTERFACE
;** SAIL imbeddable features are in lower case
ifn sail {
; INTRPT is non-zero on schedule request by SAIL
external intrpt
;** SAIL jobdat addresses
sai41: 0
saiapr: 0
saiff: 0
sairel: 0
;** SAIL interrupt mask
saimsk: 0
;** SAIL Accumulators
for @' i←0,17{ac'i:0↔}
;** save area for LISP accumulators
lispac: block 20
saifix: move a, saimsk ; fix up the SAIL interrupts (new system)
intorm a, ; OR in the SAIL interrupt bits
move a, saiapr
movem a, JOBAPR
popj 17,
;** the only interrupts that LISP knows about are POV,ILM,NXM
; i.e. bits 19,22,23
lspfix: intens a, ; flush new style interrupts while in LISP
movem a, saimsk ; save off the SAIL interrupt bits
movei a, APRFLG ; PDOV,NXM and ILM only
aprenb a,
move a, JOBAPR ; save off sail APR flag
movem a, saiapr
movei a,APRINT ; the lisp interrupt handler is here
movem a,JOBAPR
popj 17,
}
;** LISP to SAIL
;** save the state of the world before jumping to SAIL , we always return to
;the symbol lisp on the next page
ifn sail,<
intern lspsai
extern wstart ; beginning of the Interface window
extern saijob ; we go here on leaving LISP
lspsai: movem 0,lispac ; save the lisp acs
move 0,[xwd 1,lispac+1]
blt 0, lispac+17
move a, job41
movem a, lsp41
move a, jobff
movem a, lspff
move a, jobrel
movem a, lsprel
move a,sai41 ; put back the low-core job data
movem a,job41
move a,sairel
movem a,jobrel
move a,saiff
movem a,jobff
move 17,lispac+17
pushj 17, saifix ; fix up SAIL interrupt system
hrlzi 17,ac0 ; now restore the sail accumulators
blt 17, 17
jrst @saijob ; and go to the listener (or LISP_SAVE if making a system)
>
; ** SAIL to LISP
ifn sail,<
intern LISP
extern corget
offset:0 ; this is the space between FS and the end of SAIL
; when we start up
slfirst: 0 ; set non-zero after the first entry to LISP
lspsize:0 ; size of Corget block into
; which LISP gets put
cgstart:0 ; its beginning
lspff: 0 ; LISP jobdata
lsprel: 0
lsp41: 0
; this is executed each time we come back to LISP from SAIL
salisp: 0
movem 17,ac17 ; save off the SAIL accumulators
movei 17,ac0
blt 17, ac16
move a, jobff ; save off SAIL job-data
movem a, saiff
move a,jobrel
movem a, sairel
move a, job41
movem a, sai41
move 17,ac17 ; keep this temporarily for corget and lspfix
pushj 17, lspfix ; fix up LISP interrupt system
skipe slfirst ; do we need to restore LISP acs and stuff?
; (not if its the first time through)
jrst [hrlzi 17,lispac ; yes
blt 17, 17
move a,lspff ; restore JOBDAT variables for LISP
movem a,jobff
move a, lsprel
movem a,jobrel
move a,lsp41
movem a,job41
jrst .+1]
jrst @salisp ; now go to where we left off last time
; when we start up, we need to get core too (and no need to restore LISP acs)
; AC3 is the size of the lisp core image
lisp: jsr salisp ; save sail ac and restore lisp
setom slfirst ; we are now inited
hrrzi a, fs ; calculate the FS offset
hlrz b, jobsa ; this is the beginning of SAIL's corget space
movem b, cgstart ; store it
sub b,a
movem b, offset ; store the offset
move 3, -1(17) ; do this only the first time through!!
movem 3, lspsize ; this is the amount we have for free storage
pushj 17, corget ; this had better have the right arg. on the stack!
jrst [outstr[asciz/No core available!/] ; we can't get any more core
exit] ; lose big!
; go to the allocation dialogue
jrst alloc
outstr[asciz/
/]
>; end of SAIL¬LISP swop code
; ** save an LISP system and diddle starting address
ifn sail, <
extern SAISAV ; this contains the location of the first user program
; and will be the JOBSA of the saved core image
lspsav: move a, saisav
movem a, saijob ; make LISP_SAVE the place to go in SAIL
pushj p, lspsai ; now go to SAIL (but NOT at Listener)
>
; ** explicit call for RESCHEDULE by LISP
ifn sail<
reschd: setom intrpt ; tell SAIL about the interrupt
jrst lspsai
popj p,
>
SUBTTL LOADER INTERFACE
;lisp loader interface
; REG. D IS USED SINCE VARIABLES ARE MOVED WHEN LISP IS REENTRANT
LOAD: ifn sail {
;PUTTING THIS CODE BEFORE LOAD2 WILL INSURE THAT EVERYTHING WILL BE LOADED
;INTO BINARY PROGRAM SPACE, AS 'A' CONTAINS THE FLAG WHICH INDICATES WHERE
;TO PUT THE CODE. [TVR - JAN76]
hrrz a, JOBREL
movem a, CORUSE
hlre a, JOBSYM ; this is the (neg. of the ) size of the symbol table
movns a
add a, JOBREL ; this will be the top of the core after the symbol table
core a, ; hopefully get new core
jrst[outstr [asciz /No core for symbol table/]
exit] ; lose
hrlz b, JOBSYM ; copy the symbol table from hiseg
hlrzm b, hisym# ; remember where the symbol table came from in hiseg
hrr b, CORUSE
hrrm b, JOBSYM
blt b, @JOBREL
}
MOVEM A,LDPAR#
AOS B,CORUSE
MOVEM B,OLDCU#
JUMPE A,LOAD2
MOVE B,VBPORG(S)
SUBI B,INUM0
LOAD2: MOVEM B,RVAL# ;final destination of loaded code
MOVEI B,LODNME ;Look up loader file.
SETZ D, ;We haven't moved low core yet.
PUSHJ P,SYSINI
SUBI A,150 ;extra room for locations 0 to 137 and slop
MOVNS A ;length(loader)
HRRZM A,LODSIZ#
PUSHJ P,MORCOR ;expand core for loader
MOVEM A,LOWLSP# ;location of blt'ed low lisp
MOVE B,LODSIZ ;length(loader)
ADD B,A
MOVEM B,HVAL# ;temporary destination of loaded code
HRLI A,0
IFE ONESEG∨SAIL{ ;If no high segment, variables will not be moved !
MOVE D,A ;THIS IS THE RELOCATION, THE LOADER WILL SAVE IT
}
BLT A,(B) ;blt up low lisp
HLL A,NAME+3(D) ;-length(loader)
HRRI A,137-1
PUSHJ P,SYSINP
SKIPE LDFLG#(D)
JRST LOAD3
LODSYM: MOVEI B,SYMNME(D) ;Look up symbol table file.
PUSHJ P,SYSINI
MOVNS A ;length symbols
HRLM A,LDFLG#(D) ;Remember length of standard syms.
PUSHJ P,MORCOR ;expand core for symbols
SKIPGE B,JOBSYM
SOS B ;if no symbol table, use original jobsym
MOVE A,B ;Remember where standard part of sym. tbl. lives...
SUB A,JOBREL ;... but make it relative to top of core.
HRRM A,LDFLG#(D)
HLRZ A,NAME+3(D) ;-length(symbols)
ADDB A,B
HLL A,NAME+3(D) ;symbol table iowd
PUSHJ P,SYSINP
HLRS A,NAME+3(D);Subtract length of new symbols from both halves of JOBSYM.
HRLI A,-1(A) ;Fix carry problem.
ADDM A,JOBSYM
LOAD3: MOVE 3,HVAL(D) ;h
MOVE 5,RVAL(D) ;r
MOVE 2,3
SUB 2,5 ;x←h-r
HRLI 5,12 ;(w)
HRLI 2,11 ;(v)
SETZB 1,4
LODCAL: JSP 0,140 ;call the loader
HRRZM 5,RLAST#(D) ;last location loaded(in final area)
MOVE T,LOWLSP(D)
MOVE A,JOBSYM
SUB A,JOBREL ;;DWP FOR SOME REASON
HRLI A,1(A) ;; THE FUCKING LOADER IS NOT
HRR A,JOBSYM ;; UPDATING THE LEFT HALF OF JOBSYM.
;I believe junk symbol is fixed now, but unable to test due to a bug in
;the system. (TVR Feb76)
ADDI A,2 ;; ...AND IS LOADING A JUNK SYMBOL !!!
MOVEM A,JOBSYM(T)
MOVE A,JOBREL
MOVEM A,JOBREL(T) ;update jobrel
HRLZ 0,LOWLSP(D)
SOS LODSIZ(D)
BLT 0,@LODSIZ(D) ;blt down low lisp
MOVE 0,@LOWLSP ;EVERY THING IS FIXED, DON'T NEED REG. D ANYMORE
LODRTN: MOVE B,RLAST
MOVE A,RVAL
HRL A,HVAL
MOVE C,RLAST ;new coruse,maybe.
SKIPN LDPAR
JRST HILOD
BINLD: MOVEI C,INUM0(B)
CAML C,VBPEND(S)
JRST [ SETOM BPSFLG ;bps exceeded
JRST START]
MOVEM C,VBPORG(S) ;updat bporg
SOSA C,OLDCU ;old top of core
HILOD: HRRZM C,PRGBRK# ;Used by IOBRST,EXCISE.
LDRET2: BLT A,(B) ;blt down loaded code
HRRZM C,CORUSE ;top of code loaded
MOVEI B,1
ANDCAM B,JOBSYM
PUSHJ P,CORCNT ;Contract core size.
ifn sail {
hlre a, JOBSYM
movns a ; size of new symbol table
add a, JOBHRL
core2 a, ; get core at the top of high segment
jrst [outstr [asciz /No core for new Symbol Table/ ]
exit]
hrlz b, JOBSYM ; copy the symbol table back to hiseg
hrr b, hisym
blt b, @JOBHRL
hrrm b, JOBSYM ; its new location
}
JRST START
SYSINI: MOVE A,(B) ;Get name of file to be opened.
MOVEM A,NAME(D)
MOVE A,1(B) ;%% PICK UP PPN
MOVEM A,NAME+3(D) ;%% RESET VALUE HERE
OPEN 0,SYSIN0(D) ;%% OPEN CHANNEL 0 TO READ FILE
JRST AIN.4+1 ;%% ERROR IN OPEN IF HERE
LOOKUP NAME(D)
OUTSTR [ASCIZ ⊗LISP LOADER OR SYMBOL TABLE MISSING⊗]
MOVE A,[IOWD 1,NAME+3] ;KLUDGE BECAUSE OF REG. D
ADD A,D
MOVEM A,INLOW(D)
INPUT INLOW(D) ;Read first word of file, which contains
HLRO A,NAME+3(D) ; the length, and return same.
POPJ P,
REMOTE{
SYSIN0: 17 ;%% DUMP MODE I/O
SYSDEV ;%% INITIALLY SYSTEM DEVICE; MAY BE PATCHED
0 ;%% NO BUFFERING
INLOW: IOWD 1,NAME+3
0
IFN ONESEG,{SEGNME:}
NAME: 0
SYSNAM ;Loader and symbol table files have extension `IL' normally.
0
0
LODNME: LODNAM ;Name of file containing LISP loader (ext. is .IL).
SYSPPN ;PPN for above.
SYMNME: SYMNAM ;Name of file containing LISP symbol table (ext. is .IL).
SYSPPN ;PPN for above.
} ;;REMOTE
SYSINP: MOVEM A,LST(D)
INPUT LST(D)
STATZ 740000
ERR1 AIN.8
RELEASE
POPJ P,
SETLOD: PUSHJ P,SETSY1 ;Set to get loader from
MOVEM B,LODNME+1 ; some new place.
MOVEM A,LODNME
JRST TRUE
SETSYM: PUSHJ P,SETSY1 ;Set to get symbol table from
MOVEM B,SYMNME+1 ; some new place.
MOVEM A,SYMNME
JRST TRUE
;interface to alvine
IFN ALVINE,<
ED: MOVE 10,EDA
JRST (10)
PUSH P,A
HRRZ A,CORUSE
HRRM A,LST
AOS A
HRRM A,EDA#
HRRM A,ED1 ;$$SAVE REENTRY TO EDITOR
AOS ED1# ;$$
MOVSI A,(SIXBIT /ED/)
SETZ D, ;THAT RELOCATION AGAIN - SEE BELOW
PUSHJ P,SYSINI
HRLM A,LST
MOVNS A
PUSHJ P,MORCOR
PUSHJ P,SYSINP+1
POP P,A
JRST ED
GRINDEF:PUSH P,A
PUSHJ P,ED
POP P,A
JRST 2(10)>
REMOTE<
LST: 0
0>
;;CORE MANAGEMENT ROUTINES.(MORCOR,MOVSYM,EXCISE,REMSYM)
INTEGER CORUSE ;Points at first free loc. at top of lower seg. (below symbols).
;MORCOR: enter with size needed in A
;exit with pointer in A to core
MORCOR: PUSH P,B
HRRZ B,JOBSYM
SUB B,CORUSE(D)
SUBM A,B ;NEEDED-(JOBSYM-CORUSE),IE. NEEDED-FREE
JUMPL B,EXPND2
ADD B,JOBREL ;new core size
CALLI B,CORE ;expand core
ERR1 [SIXBIT /CANT EXPAND CORE !/]
PUSH P,A
MOVE A,JOBREL
MOVEM A,LSTCOR(D) ;Remember new core size (for INALLC).
PUSHJ P,MOVSYM
POP P,A
EXPND2: EXCH A,CORUSE(D)
ADDM A,CORUSE(D)
POP P,B
POPJ P,
;Move symbol table up to current top of core.
MOVSYM: MOVE B,JOBREL
HRLM B,JOBSA
HLRE A,JOBSYM
JUMPE A,MOVS1
ADDI B,1(A) ;new bottom of symbol table
MOVNI A,1(A)
ADD A,JOBSYM ;last loc of old symbol table
HRRM B,JOBSYM
PUSH P,C
MOVE B,JOBREL ;last loc of new symbol table
MOVE C,(A) ;simulated upward blt
MOVEM C,(B)
SUBI B,1
ADDI A,-1 ;lf+1,rt-1
JUMPL A,.-4
POP P,C
POPJ P,
MOVS1: HRRZM B,JOBSYM
POPJ P,
;Move symbol table down to new top of core in B.
MOVDWN: HRLM B,JOBSA ;MOVDWN must preserve B !
HLRZ A,JOBSYM
JUMPE A,MOVS1
ADDI A,1(B)
HRL A,JOBSYM
HRRM A,JOBSYM
BLT A,(B) ;downward blt
POPJ P,
EXCISE:
IFN ALVINE<
MOVEI A,ED+2
HRRM A,EDA>
SETZM PRGBRK ;Clear `code loaded at top of core' flag.
JSP R,IOBRST ;Flush i/o buffers and reset CORUSE to JRELO.
REMLSYM: ;Remove standard part (i.e., LISP.SYM) only of sym. tbl.
HLRZ B,LDFLG ;length
SOJL B,REMSY1 ;Quit if no standard syms.
MOVE A,JOBREL
ADD A,LDFLG ;Last loc. of standard syms.
ADD B,JOBSYM ;Now we blt up any user syms. that may be below the
MOVE C,JOBSYM ; standard syms.
HRLI B,-1(C) ;This fudge is needed because blt always xfers at least
BLT B,(A) ; one word.
HLRS A,LDFLG# ;Update JOBSYM by adding length of what we removed.
ADDM A,JOBSYM
REMSY1: SETZM LDFLG ;Clear sym. tbl. loaded flag.
;Contract core as much as possible...
CORCNT: MOVE B,CORUSE ;Delete space between JOBSYM and CORUSE.
SUB B,JOBSYM
ADD B,JOBREL ;Find new top of core.
ORCMI B,-2000 ;Make it a 1k boundary.
PUSHJ P,MOVDWN ;Move sym tbl (if any) down.
HRRZM B,LSTCOR ;Remember new core size for INALLC.
CALLI B,CORE
JRST .+1
JRST TRUE
REMSYM: ;Remove symbol table. Clear sym tbl present flag.
MOVE A,JOBREL
MOVEM A,JOBSYM ;Length of sym tbl is now 0.
JRST REMSY1
SUBTTL HIGH SEGMENT FUNCTIONS
IFE ONESEG {
REMOTE<VHGHORG:BHORG>
HGHCOR: JUMPE A,NOWRT ;EXPAND CORE AND SET WRITE STATUS
PUSHJ P,NUMVAL
JUMPLE A,FALSE
UNPURE ;Stanford-- make private, writable copy of segment.
UWPERR: ERR1 [SIXBIT /CAN'T CHANGE HIGH SEG. WRITE PROTECT!/]
SETZB C,WRTSTS
SETNM2 C, ;Make seg. name blank so it will be set by an SSAVE.
ERR1 @UWPERR
MOVE B,VHGHORG
ADD B,A
HRRZ C,JOBHRL
CAMG B,C
JRST TRUE
HRRZ A,B ;;DWP;; Stanford CORE2 uuo.
CORE2 A,
ERR1 [SIXBIT /CAN'T EXPAND HIGH SEGMENT!/]
JRST TRUE
NOWRT: SETOB A,WRTSTS
SETUWP A,
JRST UWPERR
JRST TRUE
REMOTE<WRTSTS: -1>
HGHORG: SKIPN A ;SET HIGH ORG. TO A AND RETURN OLD ORG.
SKIPA A,VHGHORG
PUSHJ P,NUMVAL
EXCH A,VHGHORG
JRST FIX1A
HGHEND: HRRZ A,JOBHRL ;GET VALUE OF END OF HIGH SEG.
JRST FIX1A
;SETS THE GETSEG INFO. SO USER CAN HAVE OWN HIGH SEG., AND MAKES A FILE FOR THE SEG.
SETSYS: PUSHJ P,SETSY1
MOVEM A,SEGNME ;SAVE THE FILE NAME
SETNM2 A, ;MAKE SEGNAM SAME AS FILE NAME.
MOVEM C,SEGDEV
MOVEM B,SEGPPN
MOVEM B,SEGPPX
OPEN 0,SEGOPEN ;Prepare to write out segment.
HALT
ENTER 0,SEGNME
ERR1 [SIXBIT /ENTER FAILED ON NEW SEG. NAME.!/]
MOVN A,JOBHRL ;Find length of segment.
ADDI A,400000-1
HRLI A,SHRST-1 ;Start of segment...
MOVSM A,SEGPPX ;The IOWD for writing the seg.
OUTPUT 0,SEGPPX ;Write it, already.
RELEAS 0,
JRST FALSE ;RETURN NIL
} ;END OF IFE ONESEG.
SETSY1: MOVE T,A ;MOVE ARGUMENT FOR UIOSUB
SETZM DEV ;## ALLOW DEFAULT TO DSK:
PUSHJ P,IOSUB ;BREAKS DOWN THE SPECIFICATION
MOVEI C,0
DSKPPN C, ;DSKPPN -- Find out who he is (or is aliased to).
SKIPN B,PPN
MOVE B,C ;If no PPN specified, use his.
CAMN A,SEGNME ;Don't let him use old name ...
CAMN B,C ;... unless he's on his own area.
SETSGO: SKIPA C,DEV ;Ok. Get device.
ERR1 [SIXBIT /MUSN'T CHANGE OTHER GUY'S SEGMENT NAME!/]
POPJ P,
IFN ONESEG { ;Fake high segment routines for one-segment version. They use
; binary program space as high seg.
HGHCOR: JUMPE A,CPOPJ
PUSHJ P,NUMVAL
ADD A,VBPORG(S)
CAML A,VBPEND(S)
ERR1 [SIXBIT /NEED MORE BINARY PGM. SPACE FOR HGHCOR !/]
JRST TRUE
HGHORG: SKIPN A
MOVE A,VBPORG(S)
EXCH A,VBPORG(S)
POPJ P,
HGHEND: MOVE A,VBPEND(S)
POPJ P,
} ;;END OF IFN ONESEG
SUBTTL REALLOC CODE
STRT:
INALLC: HRRZ A,JOBREL ;SEE IF CORE WAS EXPANDED
CAMN A,LSTCOR# ;OR NOT
JRST OUTALC ;NO EXPANSION - DON'T REALLOCATE
CAMG A,LSTCOR ;CHECK TO SEE IF IT GOT SMALLER!
outstr [asciz /YOU MADE CORE SMALLER, YOU ULTIMATE LOSER. NOW YOU LOSE.
/]
MOVEM A,LSTCOR ;SAVE NEW CORE BOUND
HRLM A,JOBSA
ife sail{
MOVEI P,C ;Get a fake pdl for MOVSYM.
PUSHJ P,MOVSYM ;Move symbol tbl, if any, to new top of core.
HRRZ A, JOBSYM} ;if SAIL version then leave symbol table in hiseg
ifn sail{move a, cgstart
add a, lspsize} ;This is the fake top of core
MOVEM A,JRELO# ;Top of allocated core.
SETZM PRGBRK ;Flush any code loaded at top of core.
IFN ALVINE,<
MOVEI F,ED+2 ;INDICATE THAT ED WAS OVERWRITTEN
HRRM F,EDA ;SO ED AND GRINDEF WILL BE READ IN IF NEEDED
>
INAGN: SETZM NOALIN# ;SET UP TO ASK FOR ALLOCATION
OUTSTR [ASCIZ /
ALLOC? (Y OR N) /] ;ASK USER IF HE WISHES TO SET UP
INCHRW C ;THE ALLOCATION INCREMENTS
CAIGE C,"O"
NOASK: SETOM NOALIN# ;SET FLAG SO NO INPUT IS DONE LATER
SETFWS: MOVE A,SFWS ;SAVE OLD SIZE OF FWS
MOVEM A,OSFWS#
SKIPN NOALIN ;SKIP QUESTIONS IF AUTOMATIC
OUTSTR [ASCIZ /
EXTRA FULL WORD SP. = /]
JSP R,ALLNUM
JUMPN A,.+3
SKIPE INITFW#
ADDI A,440 ;INITIAL ALLOCATION FOR FWS
ADDM A,SFWS ;ADD EITHER USER INCREMENT OR 0 TO SFWS
MOVE A,FSO# ;SAVE OLD FS ORIGIN
MOVEM A,OFSO# ;FOR RELOCATION
SKIPN NOALIN ;SKIP IF USER DONE
OUTSTR [ASCIZ /
EXTRA BIN. PROG. SP. = /]
JSP R,ALLNUM
ADDM A,SBPS
ifn sail{ add a, offset}
MOVEM A,FSMOVE# ;THE INCREMENT TO SBPS IS THE AMOUNT BY
ADDM A,FSO# ;THE FREE SPACE IS MOVED - UPDATE ORIGIN
ifn sail{setzm offset} ; now flush it just in case
SKIPN NOALIN ;SKIP IF USER DONE
OUTSTR [ASCIZ /
EXTRA REG. PDL. = /]
JSP R,ALLNUM
JUMPN A,.+3
SKIPE INITFW# ;CHECK IF INITIAL ALLOCATION
ADDI A,1000
ADDM A,SRPDL#
MOVN AR1,A ;SAVE IN CASE OF OVERFLOW
SKIPN NOALIN ;SKIP IF USER DONE
OUTSTR [ASCIZ /
EXTRA SPEC. PDL. = /]
JSP R,ALLNUM
JUMPN A,.+3
SKIPE INITFW# ;CHECK FOR INITIAL ALLOCATION
ADDI A,1040
ADDM A,SSPDL#
MOVN AR2A,A ;SAVE IN CASE OF OVERFLOW
IFN HASH,<
SKIPN INITFW
SETOM NOALIN
SKIPN NOALIN
OUTSTR [ASCIZ /
HASH = /]
JSP R,ALLNUM
CAIG A,BCKETS
JRST OCR
HRRM A,INT1
MOVNS A
HRRM A,RH4
SETOM HASHFG>
OCR: OUTSTR [ASCIZ /
/]
HRRZ A,JRELO# ;COMPUTE SIZE OF AVAILABLE CORE
ifn sail{sub a, cgstart}
ife sail{SUBI A,FS } ;SO THAT EXTRA CORE CAN BE DISTRIBUTfED
SUB A,SBPS ;TAKE OFF CORE ALLOCATED FOR BPS
SUB A,SFS ;TAKE OFF CORE IN PREVIOUS FS
SUB A,SBT ;AND ASSOCIATED BIT TABLE
SUB A,SFWS ;TAKE OFF CORE NOW ALLOCATED TO FWS
SUB A,SRPDL ;TAKE OFF CORE NOW ALLOCATED TO RPDL
SUB A,SSPDL ;TAKE OFF CORE NOW ALLOCATED TO SPDL
MOVE F,SFWS ;ESTIMATE SIZE NEEDED FOR BTF
IDIVI F,44
ADDI F,1
SUB A,F ;AND TAKE IT OFF TOTAL
MOVEM F,SBTF# ;ALSO SAVE TO RESTORE LATER
JUMPGE A,ALOK ;MAKE SURE NO OVERFLOW
OUTSTR [ASCIZ /ALLOCATIONS ARE TOO LARGE
/] ; IF SO THEN RETRY
MOVE A,OSFWS
MOVEM A,SFWS ;RESTORE SIZE OF FWS
MOVN A,FSMOVE
ADDM A,SBPS ;RESET SIZE OF BPS
ADDM A,FSO ;AND FS ORGIN
ADDM AR1,SRPDL ;RESET STACKS
ADDM AR2A,SSPDL
JRST INAGN
ALOK: MOVE B,A ;NOW CAN ALLOCATE EXCESS CORE
IFN ML2,{
SKIPE ML2ROUT
ASH B,-1
}
ACHLOC: ASH B,-4 ;1/16 TO FWS
ADDM B,SFWS
SUB A,B ;TAKE IT OFF REMAINING CORE
SKIPE INITFW
SETZ B,
ASH B,-4 ;1/64 TO PDLS
ADDM B,SSPDL
SUB A,B
ADDM B,SRPDL
SUB A,B ;AND TAKE IT OFF REMAINING CORE
MOVE T,SFWS ;CALCULATE ACTUAL SIZE OF BTF
IDIVI T,44
ADDI T,1
ADD A,SBTF ;REMOVE ESTIMATED LOSS FOR BTF
MOVEM T,SBTF
SUB A,T ;AND TAKE OFF ACTUAL LOSS TO BTF
ADD A,SFS ;ADD BACK ON SPACE FROM OLD FS
ADD A,SBT ;AND ASSOCIATED BT
;GIVING NEW SPACE AVAILABLE FOR
;FS AND BT
MOVE TT,A
IDIVI TT,41 ;SBS = SFS/32. = (SBS + SFS)/33.
ADDI TT,1
MOVEM TT,SBT
SUB A,TT ;TAKE OFF SBT FROM REMAINING CORE
MOVEM A,SFS ;GIVING AVAILABLE SFS
;SET UP REGISTERS FOR GC ETC. SETUP
ife sail{MOVEI B,FS}
ifn sail{move b, cgstart} ; this ss the new place for FS to begin
ADD B,SFS
ADD B,SBPS ;B = NFWSO (ORIGIN OF NEW FULL WORD SPACE)
MOVE C,SRPDL ;C = SRPDL
MOVE A,SFWS ;A = SFWS
MOVE F,OSFWS ;F = OLD SIZE OF FWS
HRRM B,FSTOP ;FSTOP = NFWSO
MOVN SP,B ;-NEW BOTTOM OF FWS
HRRM SP,GCMFWS
HRLZM A,C1GCS
MOVNS C1GCS ;-NEW LENGTH OF FWS
HRRM B,C1GCS ;HAVE FWS POINTER AND COUNT FOR SWEEP
ADD B,A ;NEW FIRST WORD OF BT (FS BIT TABLE)
MOVE SP,FSO ;SP = NEW ORIGIN OF FS
LSH SP,-5
SUBM B,SP ;NUMBER USED TO FIND BIT TABLE WORD
HRRM SP,GCBTP ;FROM FS WORD ADDRESS
HRLM B,C3GC ;BOTTOM OF BIT TABLES
HRRM B,GCP2
HRRM B,FWSTOP ;(ALSO UPPER BOUND ON FWS AND FS)
MOVNI SP,-2(TT) ;-SIZE OF BT (TT = SBT)
HRLM SP,C3GCS ;IOWD FOR BIT TABLE SWEEP
HRRM B,C3GCS
MOVE SP,FSO
ANDI SP,37 ;MASK OUT ALL BU LAST FIVE BITS
HRRM SP,GCBTL2 ;MAGIC NUMBER TO POSITION
SUBI SP,40
HRRM SP,GCBTL1
ADDI B,1 ;B = B + 1
HRRM B,C3GC ;BOTTOM OF FS BIT TABLE + 1
ADDI B,-2(TT) ;GET BOTTOM OF BTF - 1, POINTER IS INCREMENTED
HRRM B,C2GCS ;BEFORE USE
ADDI B,1 ;B = B + 1
HRRM B,C2GC ;BOTTOM OF FWS BIT TABLE + 1
ADDI B,-1(T) ;SINCE T IS NOW SIZE OF BTF, NOT SBTF-1
HRRM B,GCP5 ;TOP OF BIT TABLES
ADDI B,1 ;BOTTOM OF REG PDL
HRRZM B,GCP3# ;Ptr. to first loc. of rpdl.
MOVE S,ATMOV ;## S NOT SET IF LISP STARTED WITH CORE
;## ALREADY EXPANDED, SO RESET IT
HRRZI A,OBTBL(S) ;GET OBLIST POINTER
ADD A,FSMOVE ;INCREMENT TO ACCOUNT FOR MOVE OF FS
MOVEM A,(B) ;Store in first loc. of rpdl.
ADDI B,1
HRRM B,GCP4# ;ROOM FOR ACS WHICH ARE MARKED BY GC.
ADDI B,LSTMAC+1 ;Move past ac area. Used part of rpdl starts here.
MOVNI A,-<LSTMAC+2>(C);THIS IS THE ACTUAL SIZE OF RPDL ;TAKING INTO ACCOUNT THE AC AR
HRL B,A ;AFTER ALLOWING FOR THE OBLIST PTR. AND ACS
MOVEM B,C2 ;C2 is used to initialize the rpdl at the top level.
HRRZ A,JRELO# ;TOP OF CORE - FOR SPDL PTR
MOVN B,SSPDL
ADD A,B
XTRASP←←40
HRLI A,XTRASP(B) ;Reserve some words at top of SP for IDSUB and ERRORX.
MOVEM A,SC2# ;SET UP SPDL POINTER (I HOPE)
MOVN A,A ;CREATE OFFSET FOR STACK POINTERS
ADDI A,INUM0
HRRZM A,SPNM#
SETZM INITFW ;TURN OFF INITIAL ALLOCATION FLAG
;RELOCATE THE FULL WORD SPACE
;FSTOP HOLDS POINTER TO ORIGIN OF NEW FWS
;FWSO# HOLDS POINTER TO ORIGIN OF OLD FWS
;AND F HOLDS SIZE OF OLD FWS (AMOUNT TO BE MOVED)
MOVSI B,F
HRR B,FSTOP
MOVE C,FWSO#
HRRZI AR2A,-1(C) ;TAKE THE OPPORTUNITY TO GET ADDRESS
;OF END OF OLD FS (USED LATER)
HRLI C,F
MOVE A,@C ;GET WORD FROM END OF OLD FWS
MOVEM A,@B ;AND MOVE TO END OF NEW FWS
SOJGE F,.-2 ;F COUNTS DOWN WORDS IN OLDFWS
;END OF FWS RELOCATION
MOVE FF,FSMOVE ;GET FAST ACCESS TO RELOCATE SIZE FOR FS
HRRZ F,AR2A
ADD F,FF ;AND FIND WHERE TO PUT WORDS FROM
;END OF OLD FS IN NEW FS
HRRZ AR1,FSTOP ;COMPUTE FWS RELOCATION CONSTANT
SUB AR1,FWSO
;RELOCATE FS - ALSO RELOCATE ALL
;POINTERS TO FS AND TO FWS
REL1: HLRZ A,(AR2A) ;GET CAR POINTER OF OLD FS WORD
JSP R,REL4
HRLM A,(F) ;MOVE CAR TO NEW POSITION
HRRZ A,(AR2A) ;GET CDR PTR
JSP R,REL4 ;CHECK FOR FS RELOCATE
HRRM A,(F)
SUBI F,1 ;F = F -1
CAMLE AR2A,OFSO ;CHECK TO SEE IF DONE
SOJA AR2A,REL1 ;NO - GO LOOP
HRRZ A,GCMKL ;RELOCATE ARRAYS
JSP R,REL4
HRRZ D,A
MOVEM D,GCMKL
REL5: HLRZ AR2A,(D)
MOVE AR2A,(AR2A)
REL6: HLRZ A,(AR2A)
JSP R,REL4
HRLM A,(AR2A)
HRRZ A,(AR2A)
JSP R,REL4
HRRM A,(AR2A)
AOBJN AR2A,REL6
HRRZ D,(D)
JUMPN D,REL5
HLLZS BIND3 ;JUST IN CASE
SKIPE INITF ;DON'T FORGET THE INITFN
ADDM FF,INITF
SKIPE INITF1 ;## DON'T FORGET THE INIT FILES
ADDM FF,INITF1 ;##
SKIPE NOUUOF ;RELOCATE FLAGS
ADDM FF,NOUUOF
SKIPE BACTRF
ADDM FF,BACTRF
SKIPE GCGAGV
ADDM FF,GCGAGV
SKIPE RSTSW
ADDM FF,RSTSW
JRST RELFOO
REL4: CAMGE A,EFWSO ;SEE IF BEYOND END OF FWS
CAMGE A,OFSO ;OK - SEE IF MAYBE IN FS
JRST (R)
CAMGE A,FWSO ;SEE IF IN FWS
JRST .+3
ADD A,AR1 ;RELOCATE FWS POINTER
JRST (R)
ADD A,FF ;RELOCATE FS POINTER
JRST (R)
RELFOO: MOVE S,FSO ;S IS THE RELOCATOR FOR MOST MACRO
SUBI S,FS ; ajt fix so that FS starts beyond BPS
MOVEM S,ATMOV ;REFERENCES TO ATOMS AND FS
MOVE A,FSMOVE ;NOW IS THE TIME FOR ALL GOOD MEN TO
ADDM A,VBPEND(S) ;SET BPEND
IFE OLDNIL< ADDM A,NILPRP> ;## RESET NIL
HRR B,VOBLIST(S) ;## GET CURRENT VALUE OF OBLIST
HRRM B,RHX5 ;## RESET WORD THAT POSTINDEXES OFF B
HRRM B,RHX2 ;## RESET WORD POSTINDEXING OFF C
ADDM A,XXX3 ;## RESET WIERD CODE
ADDM A,XXX4 ;## RESET UNBOUND
ADDM A,FSBOT ;## RESET FSBOT (SAME WORD AS XXX5)
MOVE A,FSTOP
HRRZM A,FWSO
MOVE A,C3GCS
HRRZM A,EFWSO#
SETOM REALFLG# ;Force START to do a garbage collect.
OUTALC: SETZB F,DDTIFG
MOVE S,ATMOV
JSP R,IOBRST
JRST START
;SUBROUTINE FOR NUMBER INPUT
ALLNUM: MOVEI A,0
SKIPE NOALIN#
JRST (R)
INCHRW C
CAIN C,RUBOUT
JRST [OUTSTR [ASCIZ /XXX /]
JRST ALLNUM]
CAIL C,"0"
CAILE C,"9"
JRST BANGCK
ASH A,3
ADDI A,-"0"(C)
JRST ALLNUM+3
BANGCK: CAIE C,CR ;## TERMINATE ON CR,NOT LF
JRST (R)
SETOM NOALIN#
JRST (R)
;RETURNS 0 IF NOALIN # 0
;SETS NOALIN # 0 IF IT GETS A LINE FEED INPUT
PAGE
IFN HASH,<
REHASH:
MOVEI A,BFWS(S)
PUSH P,A
HRRM A,RHX2
HRRM A,RHX5
MOVS B,RH4#
ADD B,S ;$$PUT IN ATOM MOVE OFFSET IN B, SINCE CAN'T
;$$DOUBLE INDEX - THIS REMOVES THE FOO PROBLEM
;$$IN THE NEXT THREE FOO'S
HRRZI A,BFWS+1(B)
MOVEM A,BFWS(B)
AOBJN B,.-2
SETZM BFWS(B)
MOVSI AR2A,-BCKETS
HRR AR2A,S ;$$PUT IN ATOM MOVE OFFSET IN AR2A TO AVOID
;$$DOUBLE INDEXING WITH S IN REMOVING FOO
;$$PROBLEM
RH1:
HLRZ C,OBTBL(AR2A)
RH3: JUMPE C,RH2
HLRZ A,(C)
PUSH P,C
PUSH P,AR2A
PUSHJ P,INTERN
POP P,AR2A
POP P,C
HRRZ C,(C)
JRST RH3
RH2: AOBJN AR2A,RH1
SETZM HASHFG
POP P,A
HRRM A,@GCP3
MOVEM A,OBLIST(S)
JRST START>
PAGE
;NEW FUNCTIONS TO MAKE USE OF MODIFIED SPECIAL PDL FOR ERRORS
;$$ROUTINE TO GET POINTER TO SPDL AND MAKE IT INTO AN INUM
SPDLPT: HRRZ A,SP ;$$CREATE A POINTER TO THE CURRENT TOP OF STACK
ADD A,SPNM
POPJ P, ;$$
;$$ROUTINE TO GET LEFT HAND SIDE OF SPDL ITEM INDICATED BY AN INUM FROM SPDLPT
SPDLFT: SUB A,SPNM ;$$CONVERT TO ADDRESS
HLRE A,(A) ;$$GET LEFT HAND ITEM
JUMPL A,TRUE ;$$IF IT IS NEGATIVE IT CAME FROM A STACK
;$$POINTER AND WE RETURN T INSTEAD
;ASSHOLE! HRRZI A,(A) ;$$CLEAR OUT LEFT HAND OF AC
POPJ P, ;$$RETURN - RETURNS NIL FOR LHS ← 0
;$$ROUTINE TO GIVE RIGHT HAND SIDE OF SPDL ENTRY SPECIFIED BY AN INUM FROM SPDLPT
SPDLRT: SUB A,SPNM ;$$CONVERT TO AN ADDRESS
HRRZ A,(A) ;$$ALL RHS ITEMS ARE LEGAL, NO NEED FOR CHECK
POPJ P, ;$$
;$$ROUTINE TO GET POINTER TO NEXT EVAL BLIP ON SPDL
NEXTEV: SUB A,SPNM ;$$GET POINTER INSTEAD OF INUM
HRRZ T,SC2 ;$$GET POINTER TO BOTTOM OF SPDL
SPDNLP: CAMG A,T ;$$CHECK IF HIT THE BOTTOM OF SPDL
JRST FALSE ;$$RETURN NIL IF NO MORE INTERESTING WORDS
HLL A,(A) ;$$TEST FOR WORD WITH 0 LHS
TLZE A,-1 ;$$
SOJA A,SPDNLP;$$NOT AN INTERESTING WORD, LOOK AGAIN
ADD A,SPNM ;$$FOUND AN INTERESTING WORD, CHANGE POINTER TO INUM
POPJ P, ;$$
;$$ROUTINE TO EVALUATE A VARIABLE IN AN EARLIER CONTEXT
;$$ MORE EFFICIENT THAN EVAL WITH ALIST
EVALV: MOVE C,A ;$$ MOVE AROUND FOR ATOM CHECK
PUSHJ P,ATOM ;$$
EXCH A,C ;$$
SUB B,SPNM ;$$
JUMPE C,.+2
SUBI A,1 ;It's an atom. Get pointer to its VALUE cell.
EVALV1: CAIL B,(SP) ;$$CHECK FOR END OF SPDL
JRST GETV ;$$VARIABLE NOT REBOUND - GET CURRENT VALUE
SKIPGE (B) ;$$CHECK TO AVOID SPDL POINTERS ON STACK
AOJA B,EVALV1 ;$$
HLRZ T,(B) ;$$T←CAR(B)
CAIE T,(A) ;$$COMPARE WITH ATOM TO BE EVALUATED
AOJA B,EVALV1 ;$$NOT IT, LOOK SOME MORE
MOVE A,B ;$$GET VALUE FROM SPDL
GETV: HRRZ A,(A) ;$$GET CDR OF SPECIAL CELL
POPJ P, ;$$
UNBOND: HRRZI A,UNBOUND(S) ;$$RETURN ATOM UNBOUND
POPJ P, ;$$
;$$ROUTINE TO CLEAR SPECIAL PDL TO POSITION SPECIFIED BY INUM
CLRSPD: MOVEI B,-2-INUM0(A) ;$$ -2 TO GET OVER EVAL BLIP
HLRZ TT,SC2# ;$$GET REAL SPD POINTER WITH A LHS
ADD TT,B ;$$FIND OUT HOW MANY WORDS ARE USED
ADD B,SC2 ;$$
HRL B,TT ;$$SET UP SPD POINTER
JRST UBD ;$$UBD DOES ALL THE WORK
;$$ROUTINE TO RETURN FROM SPECIAL PDL CONTEXT, SPECIFIED BY AN
;$$EVAL BLIP, WITH A GIVEN VALUE
OUTVAL: PUSHJ P,NEXTEV ;$$FORCE TO AN EVAL BLIP
JUMPE A,FALSE ;$$ NO EVAL BLIP, RETURN NIL
HRLZI C,(<POPJ P,>) ;$$ SET TYPE OF RETURN
JRST SPRE1 ;$$ FINISH UP IN SPREDO
;$$ROUTINE TO RE-EVALUATE EXPRESSION FROM AN EVAL BLIP AND GO ON FROM
;$$ THAT CONTEXT (NOT A USER CALLABLE FUNCTION)
REVAL1: HRRZ P,1(SP) ;$$ RPDL POINTER IS UP ONE
HRRZ T,C2# ;$$
HLRZ TT,C2# ;$$
ADD TT,P ;$$
SUB TT,T ;$$
HRL P,TT ;$$
DOSET: ADD SP,[2,,2] ;DWP ... Make it point to EVAL BLIP.
DOSET1: SKIPE D,ERRTN ;$$ POP ERRSETS, LOAD CURRENT ERRSET
CAMG D,P ;$$ COMPARE TO CURRENT RPDL
XCT C ;$$ DONE, DO A STRANGE EXIT
SUB D,[XWD 1,1] ;$$ GO DOWN A WORD
POP D,ERRSW ;$$
POP D,ERRTN ;$$
SUB D,[XWD 2,2] ;$$ SKIP PROG JUNK
JRST DOSET1 ;$$ TRY AGAIN
;$$ROUTINE TO CLEAR SPD TO A GIVEN POINT AND REDO FROM THERE
;$$ A CONTAINS AN SPD INUM POINTER, FORCE IT TO BE EVAL BLIP POINTER
SPREDO: PUSHJ P,NEXTEV ;$$FORCE TO EVAL BLIP POINTER
JUMPE A,CPOPJ ;$$RETURN NIL IF NO EVAL BLIP
MOVE B,A ;$$GET THE EXPRESSION
SUB B,SPNM
HRRZ B,(B)
SPRE1.: MOVE C,[JRST EVAL] ;$$SET RETURN
SPRE1: PUSH P,B ;$$SAVE SPDL POINTER
PUSHJ P,CLRSPD ;$$CLEAR OUT SPD - INCLUDES RESTORING PROGS
POP P,A ;$$
JRST REVAL1
;$$ SPREVAL - SIMILAR TO OUTVAL BUT EVALUATES THE GIVEN VALUE
;$$AS OF THE SPECIFIED CONTEXT, EQUIVALENT TO:
;$$ (PROG2 (RPLACD (NUMVAL (SETQ A (NEXTEV A))) B) (SPREDO B))
;
SPREVAL:PUSHJ P,NEXTEV ;$$FORCE TO AN EVAL-BLIP
JUMPE A,CPOPJ ;$$RETURN NIL IF NO EVAL-BLIP
JRST SPRE1. ;$$LET SPREDO FINISH UP
;$$COMPUTES A LISP POINTER TO A STACK ENTRY
STKPTR: SUB A,SPNM
POPJ P,
SUBTTL LOW SEGMENT INCLUDING REMOTE CODE
USE LOW ;Switch to low segment.
VAR ;Program variables go here.
IFN ONESEG { LIT };If no high seg., put program constants here.
XALL
SUBTTL LISP ATOMS AND OBLIST
BEGIN OBLIST
;;GS returns the value N-1 the Nth time it is called.
DEFINE GS{GENCNT+<GENCNT←←GENCNT+1>}
GENCNT←←0 ;COUNTER FOR FAKE GENERATED SYMBOLS.
;;PN is just like GS.
DEFINE GPN{PNCNT+<PNCNT←←PNCNT+1>}
PNCNT←←0 ;COUNTER FOR PNAMES.
;;PUTOB(NAME,PTR) conses PTR onto the OBLIST bucket aprropriate to NAME.
DEFINE PUTOB(A,B) {
ZZ←←<ASCII +A+>⊗<-1> ;Get the first word of ASCII +NAME+ and make it positive.
ZZ←←ZZ - <ZZ/BCKETS>*BCKETS ;Find REMAINDER of this divided by no. of buckets.
FOR @' Y←ZZ,ZZ { ;This remainder is the bucket no. to use.
XWD B,OBT'Y ;CONS the pointer onto the right bucket.
OBT'Y←←.-1 } ;Update the pointer to the bucket.
}
DEFINE PSTRCT(A) {PSTRCX (<A>,→GPN)}
DEFINE PSTRCX ' (A,QQ)
{ZY←←0 ;Find length of the name.
FOR Xε{A}<ZY←←ZY+1 ;This counts the chrs.
>
ZY←←<ZY-1>/5 ;Change to words (actually (no. of words)-1).
DEFINE PN'QQ {PX'QQ: ASCII+A+} ;Make a new label and macro to remember name.
Q1(ZY,PX'QQ) ;Generate list structure to point at name.
}
DEFINE Q1(N,Z){
IFN N,<XWD Z,[Q1(N-1,Z+1)]>
IFE N,<XWD Z,0>}
;## ARGS ARE A←NAME, B←PROP NAME, C'A←THE PROPERTY, D←LABEL OF ATOM
DEFINE MKAT (A,B,C,D){XLIST
FOR @⊗ XXX ⊂ (A)< PUTOB XXX,.+2
UNBOUND
IFDIF {D},{} {↑D}
XWD -1,.+1
XWD B,.+1
XWD C⊗XXX,.+1
XWD PNAME,.+1
XWD [PSTRCT(XXX)],0
>
;;LIST
}
;## ARGS ARE: A←PROPERTY, B←PROP NAME, C←NAME,D←LABEL OF ATOM
DEFINE MKAT1 ' (A,B,C,D)
<XLIST
FOR @⊗ XXX⊂ (C) <PUTOB XXX,.+2
UNBOUND
IFDIF {D},{} {↑D}
XWD -1,.+1
XWD B,.+1
XWD A,.+1
XWD PNAME,.+1
XWD [PSTRCT(XXX)],0
>
;;LIST
>
DEFINE MKAT1X ' (A,B,C,D)
<XLIST
FOR @⊗ XXX⊂ (C) <
IFDIF {D},{} {↑D}
XWD -1,.+2
PUTOB XXX,.-1
XWD B,.+1
XWD A,.+1
XWD PNAME,.+1
XWD [PSTRCT(XXX)],0
>
;;LIST
>
;## ATOM WITH SYM PROPERTY ={NAME OF ATOM}
DEFINE ML1 ' (A){FOR @$ XXX⊂(A)<
V$XXX: XWD -1,.+1
XWD FIXNUM,[XXX]
MKAT(XXX,SYM,V)
>}
;## ATOM WITH SYM PROPERTY `A', NAME `B'
DEFINE MKSY1 ' (A,B){XLIST
V'A: XWD -1,.+1
XWD FIXNUM,[A]
COMMENT ⊗
PUTOB B,.+2
UNBOUND
XWD -1,.+1
XWD SYM,.+1
XWD G'QQ,.+1
XWD PNAME,.+1
XWD [PSTRCT(B)],0
⊗
MKAT1(V'A,SYM,B)
;;LIST
}
;## ATOM WITH NO PROPS WITH LABEL SAME AS ATOM NAME
DEFINE ML ' (A)<
XLIST
FOR XXX⊂(A),<PUTOB XXX,.+2
UNBOUND
↑XXX: XWD -1,.+1
XWD PNAME,.+1
XWD [PSTRCT(XXX)],0
>
;;LIST
>
;## CREATE ATOM WITH NO LABEL OR PROPS. USED FOR COMMON ATMS IN SYSTEM
DEFINE MK ' (A)<
XLIST
FOR XXX⊂(A),<PUTOB XXX,.+2
UNBOUND
XWD -1,.+1
XWD PNAME,.+1
XWD [PSTRCT(XXX)],0
>
;;LIST
>
;THE GREAT OBLIST EXPLOSION...
↑FS: ;Free storage begins here (until some binary program space is allocated!).
↑OBTBL: ;The object table (top level of the oblist) is first thing in free stg.
GLOBAL BCKETS,ONESEG,NIL
↑OBLIST: BLOCK BCKETS ;Leave space for it.
FOR @⊗ ZZ←0,BCKETS-1 {OBT⊗ZZ←←NIL ;Define a symbol per bucket for PUTOB.
}
MKAT<CADR,CDAR,CDDR,CAAAR,CAADR,CADAR,CADDR,CDAAR,CDADR,CDDAR,CDDDR>,SUBR
MKAT<CAAAAR,CAAADR,CAADAR,CAADDR,CADAAR,CADADR,CADDAR,CADDDR,CDAAAR>,SUBR
MKAT<RPLACA,RPLACD,MINUS,TERPRI,CAR,CDR,CAAR,USETI,USETO>,SUBR
MKAT<CDAADR,CDADAR,CDADDR,CDDAAR,CDDADR,CDDDAR,CDDDDR,MAKNUM,CONS>,SUBR
MKAT<STRINGP,ATOM,PATOM,EQ,PRIN1,PRINT,RETURN,EXPLODE,SASSOC,ASSOC>,SUBR
MKAT<GCGAG,CHRCT,SETIGCRLF,LINELENGTH,NUMBERP,EQUAL,GET,INTERN,MEMBER>,SUBR
MKAT<LOAD,MAKNAM,READCH,NOT,NULL,GENSYM,ZEROP,DIVIDE,GCD>,SUBR
MKAT<TIME,FIX,SET,PROG2,LENGTH,READLIST,LAST,ADD1,SUB1>,SUBR
MKAT<GCTIME,REVERSE,SPEAK,FSAVAIL,GC,GETL,BAKGAG,MEMQ>,SUBR
MKAT<PUTPROP,PRINC,FLATSIZE,ERR,EXAMINE,DEPOSIT,LSH>,SUBR
MKAT<NCONS,XCONS,REMPROP,ARG,SETARG,NOUUO,MINUSP>,SUBR
MKAT<OUTC,INC,DDTIN,INITFN,EXCISE,REMSYM,REMAINDER,ABS>,SUBR
MKAT<SUBST,COPY,PROG1,SPRINT,LITATOM,NTHCHAR,BUFFER,WORDIN>,SUBR
MKAT<DDTLOD,DDTSET,SIXMAK,SIXMRT>,SUBR
MKAT EXPLODEC,SUBR,%
MKAT TAB,SUBR,.
MKAT TYO,SUBR,I
MKAT TYI,SUBR,I
MKAT SYSNAM,SUBR,.
MKAT EXIT,SUBR,.
MKAT1 EVAL,SUBR,*EVAL,CEVAL:
MKAT1 BKTRC,SUBR,PBK
MKAT1 .UUOTR,SUBR,TRACEUUO
;$$ REDEF. FOR NEW MAP FUNCTIONS
MKAT<MAPCAN,MAPCON,MAPLIST,MAPCAR,MAP,MAPC>,LSUBR
;$$ GIVE MAPCAN THE DOUBLE NAME MAPCONC
MKAT1 MAPCAN,LSUBR,MAPCONC
MKAT PROG,FSUBR,,PROGAT:
;##LIST STARTS HERE
MKAT LIST,FSUBR,,LISTAT:
MKAT <PROGN,COND,SETQ,INPUT,OUTPUT>,FSUBR
MKAT <SETLOD,SETSYM>,FSUBR
MKAT <ERRSET,REMOB,OR,GO,ARRAY,STORE>,FSUBR
MKAT <AND,DEFPROP,CSYM,EXARRAY,INOUT>,FSUBR
MKAT1 QUOTE,FSUBR,FUNCTION
MKAT1 %CLRBFI,SUBR,CLRBFI
MKAT1 .ERROR,SUBR,ERROR
MKAT1 LINRD,SUBR,LINEREAD
MKAT1 UNBOND,SUBR,UNBOUND
MKAT1 ECHO,SUBR,TTYECHO
MKAT1 FUNCT,FSUBR,*FUNCTION
MKAT <APPEND,NCONC,BOOLE,APPLY>,LSUBR
;## LABELS ON READ AND LISP EVAL FOR BOOTS
MKAT READ,SUBR,,READAT:
MKAT EVAL,LSUBR,O,EVALAT:
MKAT ASCII,SUBR,A
MKAT <ASCIIVAL>,SUBR
MKAT QUOTE,FSUBR,,CQUOTE:
MKAT INUM0,SYM
↑VTRUTH: TRUTH
MKAT1X VTRUTH,VALUE,T,TRUTH:
PUTOB NIL,0
↑CNIL2: XWD VALUE,.+1
XWD VNIL,.+1
XWD PNAME,.+1
XWD [PSTRCT (NIL)],0
↑VNIL: NIL
↑SAVIOB: NIL
MKAT1X SAVIOB,VALUE,*SAVIOB
↑%SCNSF: NIL
MKAT1X %SCNSF,VALUE,%SCANSETFLAG%
MKSY1 %LCALL,*LCALL
MKSY1 %AMAKE,*AMAKE
MKSY1 %UDT,*UDT
MKSY1 .MAPC,*MAPC
MKSY1 .MAP,*MAP
ML1 <SPECBIND,SPECSTR,FIX1A,NSTR>
↑%NOPOINT: NIL
MKAT1X %NOPOINT,VALUE,*NOPOINT
UNBOUND
↑UNBOUND:XWD -1,.+1 ;NOTE that this atom is NOT on the oblist !
XWD PNAME,.+1
XWD [PSTRCT(UNBOUND)],0
MKAT1 EXPN1,SUBR,*EXPAND1
MKAT1 EXPAND,SUBR,*EXPAND
MKAT1 .PLUS,SUBR,*PLUS
MKAT1 .DIF,SUBR,*DIF
MKAT1 .QUO,SUBR,*QUO
MKAT1 .TIMES,SUBR,*TIMES
MKAT1 .APPEND,SUBR,*APPEND
MKAT1 .RSET,SUBR,*RSET
MKAT1 .GREAT,SUBR,*GREAT
MKAT1 .LESS,SUBR,*LESS
MKAT1 PUTSYM,SUBR,*PUTSYM
MKAT1 GETSYM,SUBR,*GETSYM
MKAT1 RPTSYM,SUBR,*RPUTSYM
MKAT1 RGTSYM,SUBR,*RGETSYM
PUTOB NUMVAL,.+2
UNBOUND
XWD -1,.+1
XWD SUBR,.+1
XWD NUMVAL,.+1
XWD SYM,.+3
XWD FIXNUM,[NUMVAL]
XWD -1,.-1
XWD .-1,.+1
XWD PNAME,.+1
XWD [PSTRCT(NUMVAL)],0
;;MKAT <OBLIST,BASE,IBASE,BPEND,BPORG>,VALUE,V
↑VOBLIST:OBLIST
MKAT1X VOBLIST,VALUE,OBLIST
↑VBASE: 8+INUM0
MKAT1X VBASE,VALUE,BASE
↑VIBASE: 8+INUM0
MKAT1X VIBASE,VALUE,IBASE
↑VBPEND: INUM0
MKAT1X VBPEND,VALUE,BPEND
↑VBPORG: INUM0
MKAT1X VBPORG,VALUE,BPORG
;## QUEUE ATOMS AND OTHER NEW FNS.
MKAT<GTBLK,ERRCH,RDNAM>,SUBR
MKAT<INUMP,NUMTYPE>,SUBR
MKAT<UFDINP,RDFILE,MYPPN,BLKLST>,SUBR
MKAT<RENAME,DELETE,INITFL>,FSUBR
ML<CPU,FORMS,LIMIT,COPIES,DISP>
;MK<SUBST,COPY,*RENAME,FILBAK,LBK,DIR>
MKAT1 ISFILE,SUBR,LOOKUP
MK<NO BACKUP >
;## MOST OF THE EXTENDED SWITCHES (NOT ALL)
;$$ATOMS FOR DEFINITIONS OF FUNCTIONS FOR NEW SPDL PACKAGE
ML ERRORX
MKAT1 INTPRP,SUBR,INITPROMPT
MKAT1 LSPRET,FSUBR,**TOP**
MKAT<PROMPT,READP,UNTYI,TYIGBL,TYIRGB,STKPTR,SPREDO,SPREVAL>,SUBR
MKAT<MEMB,NEXTEV>,SUBR
MKAT<SPDLFT,SPDLRT,SPDLPT>,SUBR
MKAT<EVALV,OUTVAL>,SUBR
;$$ MORE EXTENSIONS INCLUDING READ MACROS
ML READMACRO
MKAT1 %FLATSIZEC,SUBR,FLATSIZEC
MKAT <NEQ,CONSP,CHRVAL,SETCHR,MODCHR,LEXORDER>,SUBR
MKAT <FREE,FREELIST,SYSCLR,HGHCOR,HGHORG,HGHEND>,SUBR
MKAT1 FALSE,FSUBR,SPECIAL
MKAT1 FALSE,FSUBR,NOCALL
MKAT1 FALSE,FSUBR,DECLARE
MKAT1 FALSE,FSUBR,NILL
MKAT1 APPLY.,SUBR,APPLY#
MKAT1 .MAX,SUBR,*MAX
MKAT1 .MIN,SUBR,*MIN
;$$ THE BREAK VARIABLES WHICH TELL ABOUT DEPTH IN THE BREAK PACKAGE
↑BIOCHN: NIL
MKAT1X BIOCHN,VALUE,#%IOCHANS%#
↑BPMPT: NIL
MKAT1X BPMPT,VALUE,#%PROMPTS%#
↑BINDNT: INUM0
MKAT1X BINDNT,VALUE,#%INDENT
ML <PNAME,FIXNUM,FLONUM,VALUE,LAMBDA,SUBR,FSUBR,EXPR,FEXPR,<SYM>
,$EOF$,LABEL,FUNARG,LSUBR,MACRO>
PUTOB ?,.+2
UNBOUND
↑QST: XWD -1,.+1
XWD PNAME,.+1
XWD [PSTRCT(?)],0
;MKAT ACHLOC,SYM ;DONT KNOW WHATS UP HERE, IF NEEDED CHECK ACHLOC
GLOBAL NONUSE,STPGAP,ALVINE,QALLOW,QSWEXT,SAIL,ML2
;Let's have the # versions be identical to the others...
MKAT1 MEMBER,SUBR,MEMBER#
MKAT1 MEMQ,SUBR,MEMQ#
MKAT1 AND,FSUBR,AND#
MKAT1 OR,FSUBR,OR#
MKAT <PGLINE,PWHERE,PLSTLN>,SUBR
IFN ALVINE,<MKAT<GRINDEF>,FSUBR
MKAT<ED>,SUBR>
IFE ALVINE,<MK<GRINDEF>>
IFN QALLOW<MKAT <QUEUE>,FSUBR>
IFN QSWEXT<
ML<DEAD,AFTER>
ML<MODIFY,KILL,JOB,DEPND,UNIQUE>
ML<PAGES,PLOT,PTAPE,CARD,SEQ,PRIOR,SPACE,LIMIT,HEAD>
> ;##END OF EXTENDED SWITCHES
IFE ONESEG,{MKAT SETSYS,FSUBR}
IFN ML2,{MKAT ML2SET,SUBR
ML(SCANSET) }
MKSY1 SCANACT,SCANACT
IFN SAIL { MKAT <LSPSAI>,SUBR
MKAT <LSPSAV>,SUBR
mkat <reschd>,subr}
COMMENT ⊗
; ALL THE ATOMS IN THE WHOLE SYSTEM
MK<USERERRORX,RPUTSYM,RGETSYM>
MK<A,ADD,AFTER,ALIAS,ARGPRINT,ASSOC#,ATM,B,BEFORE,BELOW,BEND1,BF,BI,BIND>
MK<BK,BKE,BKEV,BKEVAL,BKF,BKFNLIST,BKFV,BKPOS,BKPROG,BKSETQ,BKV>
MK<BLOCK,BLOCKED,BO,BORG1,BREAK>
MK<BREAKMACROS,BREAK0,BREAK1,BREAK1ERX,BRKAPPLY>
MK<BRKCOMS,BRKEXP,BRKFN,BRKTYPE,BRKWHEN,BROKEN,BROKENFNS>
MK<BY,C,CAIE,CAIN,CALL,CALLF,CALLF@,CAME,CAMN,CAN'T,CHANGE>
MK<CHNGDFLG,CLEARB,CLEARM,COM,COM0>
MK<COMS,COMSQ,COPYFLG,CPTR,D,DE,DEFSYM,DELETE,DF>
MK<DIFFERENCE,DIFFERENT EXPRESSION,DM,DREVERSE,DRM,DSKIN>
MK<DSKOUT,DSM,DSUBST,E,EDIT,EDIT-SAVE>
MK<EDIT4E,EDIT4F,EDIT4F1,EDIT:,EDITBF,EDIT1,EDITCOMSL>
MK<EDITE,EDITF,EDITFNS,EDITFPAT>
MK<EDITL,EDITL0,EDITL1,EDITMACROS,EDITMBD,EDITMV>
MK<EDITOPS,EDITQF,EDITRACEFN,EDITXTR,EMBED,ENTER ,ERXACTION>
MK<EX,EXCH,EXTRACT,F,F=,FF,FILES-LOADED,FINDFLAG,FNDBRKPT,FOR,FOUND>
MK<FROM,FROM?=,FS,FUNTYPE,G,GETSYM,GREATERP,GRINL,GVAL>
MK<GWD,HERE,HLLZS@,HLRZ,HLRZ@,HRLM@,HRRM,HRRM@,HRRZ,HRRZ@,HRRZS@>
MK<I,IF,IN,INSERT,INSIDE,JCALL,JCALLF,JCALLF@,JRST,JSP>
MK<JUMPE,JUMPN,KLIST,L,L0,L11,L12,LAP,LAPEVAL,LAPLST,LASTAIL>
MK<LASTPOS,LASTWORD,LASTP1,LASTP2,LASTVALUE,LC,LCFLG,LCL,LDIFF,LESSP>
MK<LEXPR,LI,LO,LP,LPQ,LPTLENGTH,LSUBST>
MK<M,MARK,MARKLST,MAX,MAXLEVEL,MAXLEVEL EXCEEDED>
MK<MAXLOOP,MAXLOOP EXCEEDED,MBD,MIN,MOVE,MOVEI,MOVEM>
MK<MOVNI,MV,N,N?,NAMESCHANGED,NEX,NOT BLOCKED,NOT EDITABLE>
MK<NOTHING SAVED,NTH,NX,OCCURRENCES,OK,OLDPROMPT,OPS,ORF,ORR>
MK<P,PLEV,PLUS,POP,POPJ,PP,PREVEV,PRINLEV,PRINTLEV>
MK<PUSH,PUSHJ,PUTSYM,QLIST,QUOTIENT,R,READBUF>
MK<REDEFINED,REMOVE,REPACK,REPLACE,RETFROM,RI,RO> ;##REMOVE MARKER
MK<S,SAVE,SECOND,SELECTQ,SN,SOJE,SOJN>
MK<START,STKCOUNT,STKNAME,STKNTH>
MK<STKSRCH,STOP,SUB,SUBPAIR,SURROUND,SW>
MK<TAILP,TCONC,TDZA,TEST,THIRD,THROUGH,THRU,TIMES,TO>
MK<TOFLG,TOPFLG,TRACE,TRACEDFNS,TTY:,TYPE,UNBLOCK,UNBREAK>
MK<UNBREAK0,UNBREAKABLEFNS,UNDEF,UNDO>
MK<UNDOLST,UNDOLST1,UNDONE,UNFIND,UNTRACE,UP>
MK<UPFINDFLG,USE,USERMACROS,WHEN,WITH,X,XTR,Y,ZZ>
MK<@,<\>,<\#\ >,<\P>,↑,↑↑,←,←←, , , ?, . ,< . UNBOUND)>>
MK<- LOCATION UNCERTAIN, = ,! ,!0,!NX,!UNDO,!VALUE,##>
MK<#1,#2,#3,$%DOTFLG,%%BKPOS,%%CMDL,%%V>
MK<%DEFINE,%DEREAD,%DEVP,%ERDEPTH,%LOOKDPTH,%PREVFN%>
MK<%PRINFN,%READIN,&,& ,<(>,<(DEFPROP >,<)>,*,*ANY*,*RSETERX,-->
MK<-IN-,::,:::,/BREAK1,:,=,==,?=,??>
MK<... , ...],BINARY PROGRAM SPACE EXCEEDED>
MK<NOT A TAIL - LDIFF,NO EVAL BLIP - RETFROM>
MK<BAD ARGUMENT - LCONC,BAD ARGUMENT - TCONC>
MK<DSK:,INIT,LSP,NOT IN SYMBOL TABLE,& UNHAPPY>
MK<ARGUMENTS NOT FOUND,NOT BREAKABLE FUNCTION,ARGUMENT LIST?>
MK<AROUND,BREAKIN,EDBRK,BROKEN-IN,EDVAL,DREMOVE,LCONC,SUBLIS>
MK<EDITDSUBST,MAKEFN,FNDEF,LXPD,WHERE,MESS>
MK<SHOULD BE LIST,SHOULD BE LIST OF ATOMIC ARGUMENTS>
MK<FSUBR -- TAKES ONLY ONE ARGUMENT,UNBREAKABLE UNLESS 'IN' SOMETHING>
MK<EDITV,GRINPROPS,=EDITV,EDITP,ARGS,EDITFINDP>
;ATOMS OF GENERATED FUNCTIONS
MK<SUBFUN1ARGPRINT,SUBFUN1BREAKIN0,SUBFUN1EDITCONT,SUBFUN1EDITL1,SUBFUN1EDOR>
MK<SUBFUN1EDVAL,SUBFUN1ERRCOM>
⊗
XLIST ;Now we clean up the debris from the explosion...
USE TEMP
RELOC OBTBL ;Now go make the object table.
FOR @' ZZ←0,BCKETS-1 {XWD OBT'ZZ,IFN <ZZ-BCKETS+1>,{.+1;}0
}
USE LOW
IFN ONESEG {LIT} ;If no high segment, put rest of initial atom structure in FS.
↑BFWS: ;This is end of initial FS, beginning of FWS.
IFN ONESEG { ;This makes the text for initial atom PNAMEs, which go here in
FOR @' ZZ←0,PNCNT-1 { PN'ZZ ; full word space if there is no upper segment.
}
}
↑EFWS: 0 ;End of initial FWS. (FWS is initially empty if two segments.)
IFE ONESEG { ;If we have high segment, put rest of initial structure there.
USE HIGH ;Switch to high segment.
FOR @' ZZ←0,PNCNT-1 { PN'ZZ ;This makes the text for initial atom PNAMEs.
}
LIT ;These are prog. literals and also PNAME parts of initial atoms.
↑BHORG: 0 ;Initial value of HGHORG points here.
USE LOW ;Back to low segment.
};;end of IFE ONESEG
XPUNGE ;Here we forget about a million uninteresting symbols.
BEND OBLIST
LIST
SUBTTL LISP STORAGE ALLOCATOR (ONCE ONLY)
ALLOC: SETZM SBPS ;SET UP INITIAL ALLOCATIONS FOR SPACE
HRRZI A,BFWS-FS ;THIS IS THE SIZE OF THE ORIGINAL FS
HRRZM A,SFS
HRRZI A,EFWS-BFWS ;THIS ALLOWS ONLY THE INITIAL
HRRZM A,SFWS ;FWS
HRRZI A,0 ;THE INITIAL ALLOCATION FOR SPDL
HRRZM A,SSPDL
HRRZM A,SRPDL ;AND FOR RPDL IS SET UP IN INALLC
HRRZI A,FS
HRRZM A,FSO ;THIS SETS UP INITIAL FS POINTER
HRRZI A,BFWS ;THIS SETS UP INITIAL FWS ORIGIN POINTER
HRRZM A,FWSO#
HRRZI A,EFWS
HRRZM A,EFWSO#
MOVEI A,FS
ADDM A,VBPORG ;SET UP VARIABLE FOR BPS ORIGIN
ifn sail{move b, offset
addm b, vbporg}
SOS A
ADDM A,VBPEND
ifn sail{addm b,vbpend}
SETOM INITFW# ;FLAG FOR STANDARD INITIALIZATION OF
SETZM LSTCOR# ;OF SIZES, AND TO INDICATE CORE WAS EXPANDED
MOVEI A,1777 ;Fix up annoying loader feature...
IORM A,JOBHRL
MOVE A,JOBREL
HRLM A,JOBSA
SKIPN JOBDDT
HRRZM A,JOBSYM ;NO DDT, SO FLUSH SYMBOL TABLE.
MOVEI A,.DDT
SKIPN JOBDDT
SETDDT A, ;If no DDT, make DDT command ≡ REE and <ctrl>H.
IFE SAIL {RESET} ; careful not to clobber SAIL
MOVEI A,LISPGO
HRRM A,JOBSA
MOVEI A,DEBUGO ;SET THE REE ADDRESS
HRRM A,JOBREN
JRST INALLC
; INTERNAL and EXTERNAL declarations
EXTERNAL JOBDDT,JOBSYM,JOBHRL
DEFINE MKENT (A)<
INTERNAL A>
;##DEBUG QUEUE
MKENT <CADAR,ATMOV,CADAR,COPIES,CORUSE,DEBUGO,DEV>
MKENT <EXT,INUM0,INUMIN,IOPPN,LISTAT,MOVDWN>
MKENT <NXTIO,OLDCU,SIXMAK,SIXMRT,STNIL,%SCNSF,IDEND,INTER0>
MKENT <NUMBP2,OPOV,NUMV2,NUMV3,NUMV4,OPR,FLOOV,FIX2>
MKENT <NUM1,NUM3,BPR,FWCONS,FALSE,TRUE,PNAME,FW0CNS,NCONS>
MKENT <READ,READP1,MAKNUM,PRIN1,PRINT,EXPLODE,SASSOC,EQUAL>
MKENT <CHCT,LINL,OLDCH,FLATSIZE,TYI,RATOM,CHRCT,TYOD>
MKENT <GET,INTERN,REMOB,MAKNAM,GENSYM,FIX,LENGTH,READLIST,PATOM>
MKENT <LAST,INC,OUTC,FIX1A,NUMVAL,REVERSE,MAPLIST,GC,GETL,PUTPROP>
MKENT <ERR,MAPCAR,REMPROP,LIST,SETQ,ERRSET,REMOB,ARRAY,APPEND>
MKENT <SPECBIND,SPECSTR,XCONS,ATOM,READCH,SET,NCONC,PRINC>
MKENT <CONS,ACONS,CTY,FP7A1,TERPRI,LSPRET,PNGNK1>
MKENT <TYO,ITYO,IGSTRT,NOINFG,CHRTAB,EVAL,OEVAL,.APPEND,INPUT,OUTPUT>
IFN ALVINE,<MKENT<PSAV1,BKTRC>>
;$$ FOR ALAN'S DIRECT ACCESS INPUT
MKENT <ININBF,TYI2,TYIA,INCH>
;## FOR BILL'S DIRECT ACCESS INPUT/OUTPUT
MKENT <AIN.2,AIN.4,AIN.7,AOUT.2,CHANNE>
MKENT <CHNSUB,CHTAB,DEVDAT,ENTR,IOSUB>
MKENT <LOOKIN,OUTCH,OUTERR,POPAJ,PPN,SMAC>
MKENT <TABSR1,TABSRC,TYID,TYI2Z,TYI3B,TYO2X>
MKENT <TYO5,AIOP,SETIN,FSTOP,FSBOT,FSAVAI>
;$$ FOR ALVINE
MKENT <PROMPT,INUM0,MEMQ,UNBOUND>
;%% FOR THE MODIFIED ARITHMETIC PACKAGE
MKENT <FIXNUM,FLONUM>
IFE SAIL{ END ALLOC}
IFN SAIL{ END}